OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_constraints.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "lagmult.inc"
#include "param_c.inc"
#include "scr17_c.inc"
#include "tabsiz_c.inc"
#include "sphcom.inc"
#include "fxbcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine st_qaprint_constraints (nom_opt, inom_opt, npby, lpby, rby, ibftemp, fbftemp, ibfflux, fbfflux, itab, icode, iskew, ibcslag, ibfvel, fbfvel, nimpdisp, nimpvel, nimpacc, rwbuf, nprw, lprw, ibcscyc, irbe3, lrbe3, frbe3, mgrby, ispcond, irbe2, lrbe2, npbyl, lpbyl, rbyl, ibmpc, ibmpc2, ibmpc3, ibmpc4, rbmpc, ljoint, nnlink, lnlink, llinal, linale, gjbufi, gjbufr, ms, in, fxbipm, fxbfile_tab, glob_therm)

Function/Subroutine Documentation

◆ st_qaprint_constraints()

subroutine st_qaprint_constraints ( integer, dimension(lnopt1,snom_opt1), intent(in) nom_opt,
integer, dimension(sinom_opt), intent(in) inom_opt,
integer, dimension(nnpby,nrbykin), intent(in) npby,
integer, dimension(*), intent(in) lpby,
dimension(nrby,nrbykin), intent(in) rby,
integer, dimension(glob_therm%nift,glob_therm%nfxtemp), intent(in) ibftemp,
dimension(glob_therm%lfacther,glob_therm%nfxtemp), intent(in) fbftemp,
integer, dimension(glob_therm%nitflux,glob_therm%nfxflux), intent(in) ibfflux,
dimension(glob_therm%lfacther,glob_therm%nfxflux), intent(in) fbfflux,
integer, dimension(numnod), intent(in) itab,
integer, dimension(numnod), intent(in) icode,
integer, dimension(numnod), intent(in) iskew,
integer, dimension(5,nbcslag), intent(in) ibcslag,
integer, dimension(nifv,nfxvel), intent(in) ibfvel,
dimension(lfxvelr,nfxvel), intent(in) fbfvel,
integer, intent(in) nimpdisp,
integer, intent(in) nimpvel,
integer, intent(in) nimpacc,
dimension(nrwlp,nrwall), intent(in) rwbuf,
integer, dimension(nrwall,nnprw), intent(in) nprw,
integer, dimension(slprw), intent(in) lprw,
integer, dimension(4,nbcscyc), intent(in) ibcscyc,
integer, dimension(nrbe3l,nrbe3), intent(in) irbe3,
integer, dimension(slrbe3), intent(in) lrbe3,
dimension(6,*), intent(in) frbe3,
integer, dimension(nmgrby,smgrby), intent(in) mgrby,
integer, dimension(nispcond,*), intent(in) ispcond,
integer, dimension(nrbe2l,nrbe2), intent(in) irbe2,
integer, dimension(slrbe2), intent(in) lrbe2,
integer, dimension(nnpby,nrbylag), intent(in) npbyl,
integer, dimension(*), intent(in) lpbyl,
dimension(nrby,nrbylag), intent(in) rbyl,
integer, dimension(nummpc), intent(in) ibmpc,
integer, dimension(lmpc), intent(in) ibmpc2,
integer, dimension(lmpc), intent(in) ibmpc3,
integer, dimension(lmpc), intent(in) ibmpc4,
dimension(srbmpc), intent(in) rbmpc,
integer, dimension(*), intent(in) ljoint,
integer, dimension(10,snnlink), intent(in) nnlink,
integer, dimension(slnlink), intent(in) lnlink,
integer, intent(in) llinal,
integer, dimension(llinal), intent(in) linale,
integer, dimension(lkjni,*), intent(in) gjbufi,
dimension(lkjnr,*), intent(in) gjbufr,
dimension(*), intent(in) ms,
dimension(*), intent(in) in,
integer, dimension(nbipm,nfxbody), intent(in) fxbipm,
character, dimension(nfxbody) fxbfile_tab,
type (glob_therm_), intent(in) glob_therm )

Definition at line 32 of file st_qaprint_constraints.F.

42C============================================================================
43C M o d u l e s
44C-----------------------------------------------
45 USE qa_out_mod
46 USE r2r_mod
47 USE bcs_mod
48 USE names_and_titles_mod , ONLY : nchartitle
49 use glob_therm_mod
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "com04_c.inc"
58#include "lagmult.inc"
59#include "param_c.inc"
60#include "scr17_c.inc"
61#include "tabsiz_c.inc"
62#include "sphcom.inc"
63#include "fxbcom.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER, INTENT(IN) :: NOM_OPT(LNOPT1,SNOM_OPT1), INOM_OPT(SINOM_OPT)
68 INTEGER, INTENT(IN) :: ITAB(NUMNOD)
69 TYPE (glob_therm_) ,intent(in) :: glob_therm
70C-----------------------------------------------
71C NOM_OPT(LNOPT1,SNOM_OPT1)
72C * Possibly, NOM_OPT(1) = ID
73C NOM_OPT(LNOPT1-LTITL+1:LTITL) <=> TITLES of the OPTIONS
74C--------------------------------------------------
75C SNOM_OPT1= NRBODY+NACCELM+NVOLU+NINTER+NINTSUB+
76C + NRWALL+NJOINT+NSECT+NLINK+
77C + NUMSKW+1+NUMFRAM+1+NFXBODY+NFLOW+NRBE2+
78C + NRBE3+NSUBMOD+NFXVEL+NUMBCS+NUMMPC+
79C + NGJOINT+NUNIT0+NFUNCT+NADMESH+
80C + NSPHIO+NSPCOND+NRBYKIN+NEBCS+
81C + NINICRACK+NODMAS+NBGAUGE+NCLUSTER+NINTERFRIC+
82C + NRBMERGE
83C-----------------------------------------------
84C INOM_OPT(SINOM_OPT)
85C--------------------------------------------------
86C INOM_OPT(1) = NRBODY
87C INOM_OPT(2) = INOM_OPT(1) + NACCELM
88C INOM_OPT(3) = INOM_OPT(2) + NVOLU
89C INOM_OPT(4) = INOM_OPT(3) + NINTER
90C INOM_OPT(5) = INOM_OPT(4) + NINTSUB
91C INOM_OPT(6) = INOM_OPT(5) + NRWALL
92C INOM_OPT(7) = INOM_OPT(6)
93C INOM_OPT(8) = INOM_OPT(7) + NJOINT
94C INOM_OPT(9) = INOM_OPT(8) + NSECT
95C INOM_OPT(10)= INOM_OPT(9) + NLINK
96C INOM_OPT(11)= INOM_OPT(10)+ NUMSKW+1+NUMFRAM+1+NSUBMOD
97C INOM_OPT(12)= INOM_OPT(11)+ NFXBODY
98C INOM_OPT(13)= INOM_OPT(12)+ NFLOW
99C INOM_OPT(14)= INOM_OPT(13)+ NRBE2
100C INOM_OPT(15)= INOM_OPT(14)+ NRBE3
101C INOM_OPT(16)= INOM_OPT(15)+ NFXVEL
102C INOM_OPT(17)= INOM_OPT(16)+ NUMBCS
103C INOM_OPT(18)= INOM_OPT(17)+ NUMMPC
104C INOM_OPT(19)= INOM_OPT(18)+ NGJOINT
105C INOM_OPT(20)= INOM_OPT(19)+ NUNIT0
106C INOM_OPT(21)= INOM_OPT(20)+ NFUNCT
107C INOM_OPT(22)= INOM_OPT(21)+ NADMESH
108C INOM_OPT(23)= INOM_OPT(22)+ NSPHIO
109C INOM_OPT(24)= INOM_OPT(23)+ NSPCOND
110C INOM_OPT(25)= INOM_OPT(24)+ NEBCS
111C INOM_OPT(26)= INOM_OPT(25)+ NINICRACK
112C INOM_OPT(27)= INOM_OPT(26)+ NODMAS
113C INOM_OPT(28)= INOM_OPT(27)+ NBGAUGE
114C INOM_OPT(29)= INOM_OPT(28)+ NCLUSTER
115C INOM_OPT(30)= INOM_OPT(29)+ NINTERFRIC
116C INOM_OPT(31)= INOM_OPT(30)+ NRBMERGE
117C .. TO BE MAINTAINED (cf doc/inom_opt.txt) ..
118C-----------------------------------------------
119 INTEGER, INTENT(IN) :: NIMPDISP,NIMPVEL,NIMPACC
120 INTEGER, INTENT(IN) :: NPBY(NNPBY,NRBYKIN), NPBYL(NNPBY,NRBYLAG),
121 . LPBY(*), LPBYL(*), IBCSCYC(4,NBCSCYC)
122 INTEGER, INTENT(IN) :: IBFTEMP(GLOB_THERM%NIFT,GLOB_THERM%NFXTEMP)
123 INTEGER, INTENT(IN) :: IBFFLUX(GLOB_THERM%NITFLUX,GLOB_THERM%NFXFLUX)
124 INTEGER, INTENT(IN) :: ICODE(NUMNOD), ISKEW(NUMNOD),IBFVEL(NIFV,NFXVEL)
125 INTEGER, INTENT(IN) :: IBCSLAG(5,NBCSLAG),NPRW(NRWALL,NNPRW),LPRW(SLPRW)
126 INTEGER, INTENT(IN) :: IRBE3(NRBE3L,NRBE3), LRBE3(SLRBE3)
127 INTEGER, INTENT(IN) :: IRBE2(NRBE2L,NRBE2), LRBE2(SLRBE2)
128 INTEGER, INTENT(IN) :: NNLINK(10,SNNLINK), LNLINK(SLNLINK)
129 INTEGER, DIMENSION(NRWALL) :: IDX, IDS
130 INTEGER, DIMENSION(NFXBODY) :: IDXFX, IDSFX
131 INTEGER, INTENT(IN) :: MGRBY(NMGRBY,SMGRBY)
132 INTEGER, INTENT(IN) :: ISPCOND(NISPCOND,*),LJOINT(*),GJBUFI(LKJNI,*)
133 INTEGER, INTENT(IN) :: IBMPC(NUMMPC),IBMPC2(LMPC),IBMPC3(LMPC),IBMPC4(LMPC)
134 my_real, INTENT(IN) ::
135 . rby(nrby,nrbykin),rbyl(nrby,nrbylag),frbe3(6,*),gjbufr(lkjnr,*),ms(*),in(*)
136 my_real, INTENT(IN) :: fbftemp(glob_therm%LFACTHER,glob_therm%NFXTEMP)
137 my_real, INTENT(IN) :: fbfflux(glob_therm%LFACTHER,glob_therm%NFXFLUX)
138 my_real, INTENT(IN) :: fbfvel(lfxvelr,nfxvel)
139 my_real, INTENT(IN) ::
140 . rwbuf(nrwlp,nrwall)
141 my_real, INTENT(IN) ::
142 . rbmpc(srbmpc)
143 INTEGER, INTENT(IN) :: LLINAL
144 INTEGER, DIMENSION(LLINAL), INTENT(IN) :: LINALE
145 INTEGER, INTENT(IN) :: FXBIPM(NBIPM,NFXBODY)
146 CHARACTER, DIMENSION(NFXBODY) :: FXBFILE_TAB*2148
147C--------------------------------------------------
148C L o c a l V a r i a b l e s
149C-----------------------------------------------
150 INTEGER I, II, MY_ID, MY_RBODY, MY_CONSTRAINT, MY_NODE, MY_RWALL, POSI(NRWALL+1),
151 . MY_MERGE, TNSL, NS, MY_FXBODY
152 CHARACTER(LEN=NCHARTITLE) :: TITR
153 CHARACTER (LEN=255) :: VARNAME
154 DOUBLE PRECISION TEMP_DOUBLE
155 INTEGER TEMP_INTEGER
156 INTEGER IADS,ITMP
157C-----------------------------------------------
158C Rigid Bodies
159C-----------------------------------------------
160 IF (myqakey('/RBODY')) THEN
161 DO my_rbody=1,nrbykin
162C
163 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,my_rbody),ltitr)
164 my_id = npby(6,my_rbody)
165 IF(len_trim(titr)/=0)THEN
166 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
167 ELSE
168 CALL qaprint('A_RIGID_BODY_FAKE_NAME',my_id,0.0_8)
169 END IF
170C
171 DO i=1,nnpby
172 IF(npby(i,my_rbody) /=0)THEN
173C
174C VARNAME: variable name in ref.extract (without blanks)
175 WRITE(varname,'(A,I0)') 'NPBY_',i
176 CALL qaprint(varname(1:len_trim(varname)),npby(i,my_rbody),0.0_8)
177 END IF
178 END DO
179C
180 DO i=npby(11,my_rbody)+1,npby(11,my_rbody)+npby(2,my_rbody)
181C
182C VARNAME: variable name in ref.extract (without blanks)
183 WRITE(varname,'(A,I0)') 'LPBY_',i
184 CALL qaprint(varname(1:len_trim(varname)),lpby(i),0.0_8)
185 END DO
186C
187 DO i=1,nrby
188 IF(rby(i,my_rbody)/=zero)THEN
189C
190C VARNAME: variable name in ref.extract (without blanks)
191 WRITE(varname,'(A,I0)') 'RBY_',i
192 temp_double = rby(i,my_rbody)
193 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
194 END IF
195 END DO
196C
197 END DO ! MY_RBODY=1,NRBYKIN
198C-------
199 tnsl=0
200 DO my_rbody=1,nrbylag
201C
202 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,nrbykin+my_rbody),ltitr)
203 my_id = npbyl(6,my_rbody)
204 IF(len_trim(titr)/=0)THEN
205 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
206 ELSE
207 CALL qaprint('A_RIGID_BODY_FAKE_NAME',my_id,0.0_8)
208 END IF
209C
210 DO i=1,nnpby
211 IF(npbyl(i,my_rbody) /=0)THEN
212C
213C VARNAME: variable name in ref.extract (without blanks)
214 WRITE(varname,'(A,I0)') 'NPBYL_',i
215 CALL qaprint(varname(1:len_trim(varname)),npbyl(i,my_rbody),0.0_8)
216 END IF
217 END DO
218C
219 DO i=1,npbyl(2,my_rbody)-1
220C
221C VARNAME: variable name in ref.extract (without blanks)
222 WRITE(varname,'(A,I0)') 'LPBYL_',i
223 CALL qaprint(varname(1:len_trim(varname)),itab(lpbyl(tnsl+i)),0.0_8)
224 END DO
225C
226 DO i=1,nrby
227 IF(rbyl(i,my_rbody)/=zero)THEN
228C
229C VARNAME: variable name in ref.extract (without blanks)
230 WRITE(varname,'(A,I0)') 'RBYL_',i
231 temp_double = rbyl(i,my_rbody)
232 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
233 END IF
234 END DO
235C
236 tnsl=tnsl+3*npbyl(2,my_rbody)
237 END DO ! MY_RBODY=1,NRBODY
238 END IF
239C-----------------------------------------------
240C BCS
241C-----------------------------------------------
242 IF (myqakey('/BCS') .OR. myqakey('/ALE/BCS')) THEN
243 DO my_node=1,numnod
244C
245 my_id = itab(my_node)
246C
247 IF(icode(my_node)/=0)THEN
248C VARNAME: variable name in ref.extract (without blanks)
249 WRITE(varname,'(A,I0,I0)') 'ICODE_',my_id
250 CALL qaprint(varname(1:len_trim(varname)),icode(my_node),0.0_8)
251 END IF
252C
253 IF(iskew(my_node)/=0)THEN
254C
255C VARNAME: variable name in ref.extract (without blanks)
256 WRITE(varname,'(A,I0,I0)') 'ISKEW_',my_id
257 CALL qaprint(varname(1:len_trim(varname)),iskew(my_node),0.0_8)
258 END IF
259C
260 END DO ! MY_NODE=1,NUMNOD
261 END IF
262C-----------------------------------------------
263C /IMPTEMP
264C-----------------------------------------------
265 IF (myqakey('/IMPTEMP')) THEN
266 DO my_constraint=1,glob_therm%NFXTEMP
267C
268C Title of the option was not stored in NOM_OPT ... TBD
269C and Imptemp ID is not stored
270 titr(1:nchartitle)=''
271 IF(len_trim(titr)/=0)THEN
272 CALL qaprint(titr(1:len_trim(titr)),my_constraint,0.0_8)
273 ELSE
274 CALL qaprint('A_IMPTEMP_FAKE_NAME',my_constraint,0.0_8)
275 END IF
276C
277 DO i=1,glob_therm%NIFT
278 IF(ibftemp(i,my_constraint) /=0)THEN
279C
280C VARNAME: variable name in ref.extract (without blanks)
281 WRITE(varname,'(A,I0)') 'IBFTEMP_',i ! IBFTEMP(11) => 'IBFTEMP_11'
282 CALL qaprint(varname(1:len_trim(varname)),ibftemp(i,my_constraint),0.0_8)
283 END IF
284 END DO
285C
286 DO i=1,glob_therm%LFACTHER
287 IF(fbftemp(i,my_constraint)/=zero)THEN
288C
289C VARNAME: variable name in ref.extract (without blanks)
290 WRITE(varname,'(A,I0)') 'FBFTEMP_',i
291 temp_double = fbftemp(i,my_constraint)
292 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
293 END IF
294 END DO
295C
296 END DO ! MY_CONSTRAINT=1,NFXTEMP
297 END IF
298C-----------------------------------------------
299C /IMPDISP
300C-----------------------------------------------
301 IF (myqakey('/IMPDISP')) THEN
302 DO my_constraint=1,nimpdisp
303C
304 titr(1:nchartitle)=''
305 IF(len_trim(titr)/=0)THEN
306 CALL qaprint(titr(1:len_trim(titr)),my_constraint,0.0_8)
307 ELSE
308 CALL qaprint('A_IMPACC_FAKE_NAME',my_constraint,0.0_8)
309 END IF
310C
311 DO i=1,nifv
312 IF (ibfvel(i,my_constraint) /=0) THEN
313C
314C VARNAME: variable name in ref.extract (without blanks)
315 WRITE(varname,'(A,I0)') 'IBFVEL_',i
316 CALL qaprint(varname(1:len_trim(varname)),ibfvel(i,my_constraint),0.0_8)
317 END IF
318 END DO
319C
320 DO i=1,lfxvelr
321 IF(fbfvel(i,my_constraint)/=zero)THEN
322C
323C VARNAME: variable name in ref.extract (without blanks)
324 WRITE(varname,'(A,I0)') 'FBFVEL_',i
325 temp_double = fbfvel(i,my_constraint)
326 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
327 END IF
328 END DO
329C
330 END DO ! MY_CONSTRAINT=NFXVEL-NIMPACC+1,NFXVEL
331 END IF
332C-----------------------------------------------
333C /IMPVEL
334C-----------------------------------------------
335 IF (myqakey('/IMPVEL')) THEN
336 DO my_constraint=nimpdisp+1,nimpdisp+nimpvel
337C
338 titr(1:nchartitle)=''
339 IF(len_trim(titr)/=0)THEN
340 CALL qaprint(titr(1:len_trim(titr)),my_constraint,0.0_8)
341 ELSE
342 CALL qaprint('A_IMPACC_FAKE_NAME',my_constraint,0.0_8)
343 END IF
344C
345 DO i=1,nifv
346 IF (ibfvel(i,my_constraint) /=0) THEN
347C
348C VARNAME: variable name in ref.extract (without blanks)
349 WRITE(varname,'(A,I0)') 'IBFVEL_',i
350 CALL qaprint(varname(1:len_trim(varname)),ibfvel(i,my_constraint),0.0_8)
351 END IF
352 END DO
353C
354 DO i=1,lfxvelr
355 IF(fbfvel(i,my_constraint)/=zero)THEN
356C
357C VARNAME: variable name in ref.extract (without blanks)
358 WRITE(varname,'(A,I0)') 'FBFVEL_',i
359 temp_double = fbfvel(i,my_constraint)
360 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
361 END IF
362 END DO
363C
364 END DO ! MY_CONSTRAINT=NFXVEL-NIMPACC+1,NFXVEL
365 END IF
366C-----------------------------------------------
367C /IMPACC
368C-----------------------------------------------
369 IF (myqakey('/IMPACC')) THEN
370 DO my_constraint=nfxvel-nimpacc+1,nfxvel
371C
372C Title of the option was not stored in NOM_OPT ... TBD
373C and Impvel ID is not stored
374 titr(1:nchartitle)=''
375 IF(len_trim(titr)/=0)THEN
376 CALL qaprint(titr(1:len_trim(titr)),my_constraint,0.0_8)
377 ELSE
378 CALL qaprint('A_IMPACC_FAKE_NAME',my_constraint,0.0_8)
379 END IF
380C
381 DO i=1,nifv
382 IF (ibfvel(i,my_constraint) /=0) THEN
383C
384C VARNAME: variable name in ref.extract (without blanks)
385 WRITE(varname,'(A,I0)') 'IBFVEL_',i
386 CALL qaprint(varname(1:len_trim(varname)),ibfvel(i,my_constraint),0.0_8)
387 END IF
388 END DO
389C
390 DO i=1,lfxvelr
391 IF(fbfvel(i,my_constraint)/=zero)THEN
392C
393C VARNAME: variable name in ref.extract (without blanks)
394 WRITE(varname,'(A,I0)') 'FBFVEL_',i
395 temp_double = fbfvel(i,my_constraint)
396 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
397 END IF
398 END DO
399C
400 END DO ! MY_CONSTRAINT=NFXVEL-NIMPACC+1,NFXVEL
401 END IF
402C-----------------------------------------------
403C /IMPFLUX
404C-----------------------------------------------
405 IF (myqakey('/IMPFLUX')) THEN
406 DO my_constraint=1,glob_therm%NFXFLUX
407C
408C Title of the option was not stored in NOM_OPT ... TBD
409C and Impflux ID is not stored
410 titr(1:nchartitle)=''
411 IF(len_trim(titr)/=0)THEN
412 CALL qaprint(titr(1:len_trim(titr)),my_constraint,0.0_8)
413 ELSE
414 CALL qaprint('A_IMPFLUX_FAKE_NAME',my_constraint,0.0_8)
415 END IF
416C
417 DO i=1,glob_therm%NITFLUX
418 IF(ibfflux(i,my_constraint) /=0)THEN
419C
420C VARNAME: variable name in ref.extract (without blanks)
421 WRITE(varname,'(A,I0)') 'IBFFLUX_',i ! IBFFLUX(11) => 'IBFFLUX_11'
422 CALL qaprint(varname(1:len_trim(varname)),ibfflux(i,my_constraint),0.0_8)
423 END IF
424 END DO
425C
426 DO i=1,glob_therm%LFACTHER
427 IF(fbfflux(i,my_constraint)/=zero)THEN
428C
429C VARNAME: variable name in ref.extract (without blanks)
430 WRITE(varname,'(A,I0)') 'FBFFLUX_',i
431 temp_double = fbfflux(i,my_constraint)
432 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
433 END IF
434 END DO
435C
436 END DO ! my_constraint=1,nfxflux
437 END IF
438C-----------------------------------------------
439C /BCS/LAGMUL
440C-----------------------------------------------
441 IF (myqakey('/BCS/LAGMUL')) THEN
442 DO my_constraint=1,nbcslag
443C
444 titr(1:nchartitle)=''
445 my_id = ibcslag(5,my_constraint)
446 IF(len_trim(titr)/=0)THEN
447 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
448 ELSE
449 CALL qaprint('A_BCS_LAGMUL_FAKE_NAME',my_id,0.0_8)
450 END IF
451C
452 DO i=1,5
453C
454 IF(ibcslag(i,my_constraint)/=0)THEN
455C
456C VARNAME: variable name in ref.extract (without blanks)
457 WRITE(varname,'(A,I0,I0)') 'IBCSLAG_',i ! IBCSLAG(11) => 'IBCSLAG_11'
458 CALL qaprint(varname(1:len_trim(varname)),ibcslag(i,my_constraint),0.0_8)
459 END IF
460C
461 END DO
462C
463 END DO ! MY_CONSTRAINT=1,NBCSLAG
464 END IF
465C-----------------------------------------------
466C /BCS/CYCLIC
467C-----------------------------------------------
468 IF (myqakey('/BCS/CYCLIC')) THEN
469 DO my_constraint=1,nbcscyc
470C
471 titr(1:nchartitle)=''
472 my_id = ibcscyc(4,my_constraint)
473 IF(len_trim(titr)/=0)THEN
474 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
475 ELSE
476 CALL qaprint('A_BCS_CYCLIC_FAKE_NAME',my_id,0.0_8)
477 END IF
478C
479 DO i=1,4
480C
481 IF(ibcscyc(i,my_constraint)/=0)THEN
482C
483C VARNAME: variable name in ref.extract (without blanks)
484 WRITE(varname,'(A,I0,I0)') 'IBCSCYC_',i
485 CALL qaprint(varname(1:len_trim(varname)),ibcscyc(i,my_constraint),0.0_8)
486 END IF
487C
488 END DO
489C
490 END DO ! MY_CONSTRAINT=1,NBCSCYC
491 END IF
492C-----------------------------------------------
493C /BCS/WALL
494C-----------------------------------------------
495 IF (myqakey('/BCS/WALL')) THEN
496 DO my_constraint=1,bcs%NUM_WALL
497
498 titr(1:nchartitle)=''
499 my_id = bcs%WALL(my_constraint)%user_id
500 IF(len_trim(titr)/=0)THEN
501 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
502 ELSE
503 CALL qaprint('A_BCS_WALL_FAKE_NAME',my_id,0.0_8)
504 END IF
505 !
506 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__IS_DEPENDING_ON_TIME_'
507 temp_integer = 0
508 IF(bcs%WALL(my_constraint)%IS_DEPENDING_ON_TIME)temp_integer=1
509 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
510 !
511 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__IS_DEPENDING_ON_SENSOR_'
512 temp_integer = 0
513 IF(bcs%WALL(my_constraint)%IS_DEPENDING_ON_SENSOR)temp_integer=1
514 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
515 !
516 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__GRNOD_ID_'
517 temp_integer = bcs%WALL(my_constraint)%GRNOD_ID
518 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
519 !
520 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__SENSOR_ID_'
521 temp_integer = bcs%WALL(my_constraint)%SENSOR_ID
522 CALL qaprint(varname(1:len_trim(varname)),temp_integer,0.0_8)
523 !
524 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__TSTART_'
525 temp_double = bcs%WALL(my_constraint)%TSTART
526 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
527 !
528 WRITE(varname,'(A,I0,A)') 'BCS_WALL_',my_constraint,'__tstop_'
529 TEMP_DOUBLE = BCS%WALL(MY_CONSTRAINT)%TSTOP
530 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
531 !
532 WRITE(VARNAME,'(a,i0,a)') 'bcs_wall_',MY_CONSTRAINT,'__list__size_'
533 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%SIZE
534 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
535 !
536 ITMP=TEMP_INTEGER
537 IF(ITMP == 1)THEN
538 WRITE(VARNAME,'(a,i0,a)') 'bcs_wall_',MY_CONSTRAINT,'__list__elem_1_'
539 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%ELEM(1)
540 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
541 !
542 WRITE(VARNAME,'(a,i0,a)') 'bcs_wall_',MY_CONSTRAINT,'__list__face_1_'
543 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%FACE(1)
544 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
545 ELSEIF(ITMP > 1)THEN
546 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%ELEM(1)
547 WRITE(VARNAME,'(a,i0,a,i0,a)') 'bcs_wall_',MY_CONSTRAINT,'__list__elems_ ',TEMP_INTEGER,' ...'
548 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%ELEM(ITMP)
549 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
550 !
551 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%FACE(1)
552 WRITE(VARNAME,'(a,i0,a,i0,a)') 'bcs_wall_',MY_CONSTRAINT,'__list__faces_ ',TEMP_INTEGER,' ...'
553 TEMP_INTEGER = BCS%WALL(MY_CONSTRAINT)%LIST%FACE(ITMP)
554 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
555 ENDIF
556
557 END DO ! MY_CONSTRAINT=1,BCS%NUM_WALL
558 END IF
559C-----------------------------------------------
560C /BCS/NRF
561C-----------------------------------------------
562 IF (MYQAKEY('/bcs/nrf')) THEN
563 DO MY_CONSTRAINT=1,BCS%NUM_NRF
564
565 TITR(1:nchartitle)=''
566 MY_ID = BCS%NRF(MY_CONSTRAINT)%user_id
567 IF(LEN_TRIM(TITR)/=0)THEN
568 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
569 ELSE
570 CALL QAPRINT('a_bcs_nrf_fake_name',MY_ID,0.0_8)
571 END IF
572 !
573 WRITE(VARNAME,'(a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__grnod_id_'
574 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%SET_ID
575 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
576 !
577 WRITE(VARNAME,'(a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__list__size_'
578 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%SIZE
579 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
580 !
581 ITMP=TEMP_INTEGER
582 IF(ITMP == 1)THEN
583 WRITE(VARNAME,'(a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__list__elem_1_'
584 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%ELEM(1)
585 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
586 !
587 WRITE(VARNAME,'(a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__list__face_1_'
588 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%FACE(1)
589 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
590 ELSEIF(ITMP > 1)THEN
591 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%ELEM(1)
592 WRITE(VARNAME,'(a,i0,a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__list__elems_ ',TEMP_INTEGER,' ...'
593 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%ELEM(ITMP)
594 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
595 !
596 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%FACE(1)
597 WRITE(VARNAME,'(a,i0,a,i0,a)') 'bcs_nrf_',MY_CONSTRAINT,'__list__faces_ ',TEMP_INTEGER,' ...'
598 TEMP_INTEGER = BCS%NRF(MY_CONSTRAINT)%LIST%FACE(ITMP)
599 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),TEMP_INTEGER,0.0_8)
600 ENDIF
601
602 END DO ! MY_CONSTRAINT=1,BCS%NUM_NRF
603 END IF
604C-----------------------------------------------
605C /RWALL
606C-----------------------------------------------
607 IF (MYQAKEY('/rwall')) THEN
608 IF (NRWALL > 0) THEN
609C
610! Sort by ID to ensure internal order independent output
611 POSI(1) = 1
612 DO I = 1, NRWALL
613 IDS(I) = NOM_OPT(LNOPT1*INOM_OPT(5)+1,I)
614 IDX(I) = I
615 POSI(I+1) = POSI(I) + NPRW(I,1)+INT(RWBUF(8,I))
616 ENDDO
617 CALL QUICKSORT_I2(IDS, IDX, 1, NRWALL)
618C
619! Loop over RWALLs
620 DO II = 1,NRWALL
621C
622 MY_RWALL = IDX(II)
623 TITR(1:nchartitle)=''
624 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,MY_RWALL),LTITR)
625 MY_ID = NOM_OPT(1,MY_RWALL + INOM_OPT(5))
626 IF (LEN_TRIM(TITR) /= 0) THEN
627 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
628 ELSE
629 CALL QAPRINT('a_rwall_fake_name',MY_ID,0.0_8)
630 END IF
631C
632 DO I = 1,NNPRW
633 IF (NPRW(MY_RWALL,I) /= 0) THEN
634C
635C VARNAME: variable name in ref.extract (without blanks)
636 WRITE(VARNAME,'(a,i0)') 'nprw_',I
637 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),NPRW(MY_RWALL,I),0.0_8)
638 END IF
639 END DO
640C
641 DO I = 1,NRWLP
642 IF (RWBUF(I,MY_RWALL) /= ZERO) THEN
643C
644C VARNAME: variable name in ref.extract (without blanks)
645 WRITE(VARNAME,'(a,i0)') 'rwbuf_',I
646 TEMP_DOUBLE = RWBUF(I,MY_RWALL)
647 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
648 END IF
649 END DO
650C
651 DO I = POSI(MY_RWALL),POSI(MY_RWALL+1)-1
652 IF (LPRW(I) /= 0) THEN
653C
654C VARNAME: variable name in ref.extract (without blanks)
655 WRITE(VARNAME,'(a,i0)') 'lprw_',I-POSI(MY_RWALL)+1
656 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),LPRW(I),0.0_8)
657 END IF
658 END DO
659C
660 END DO
661C
662 ENDIF
663 ENDIF
664C-----------------------------------------------
665C RBE3
666C-----------------------------------------------
667 IF (MYQAKEY('/rbe3')) THEN
668 IADS = SLRBE3/2
669 DO MY_CONSTRAINT=1,NRBE3
670C
671 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,MY_CONSTRAINT + INOM_OPT(14)),LTITR)
672 MY_ID = IRBE3(2,MY_CONSTRAINT)
673 IF(LEN_TRIM(TITR)/=0)THEN
674 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
675 ELSE
676 CALL QAPRINT('a_rbe3_fake_name',MY_ID,0.0_8)
677 END IF
678C
679 DO I=1,NRBE3L
680 IF(IRBE3(I,MY_CONSTRAINT) /=0)THEN
681C
682C VARNAME: variable name in ref.extract (without blanks)
683 WRITE(VARNAME,'(a,i0)') 'irbe3_',I
684 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IRBE3(I,MY_CONSTRAINT),0.0_8)
685 END IF
686 END DO
687C
688 DO I=IRBE3(1,MY_CONSTRAINT)+1,IRBE3(1,MY_CONSTRAINT)+IRBE3(5,MY_CONSTRAINT)
689C
690C VARNAME: variable name in ref.extract (without blanks)
691 WRITE(VARNAME,'(a,i0)') 'lrbe3_',I
692 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),LRBE3(I),0.0_8)
693 END DO
694C
695 DO I=IRBE3(1,MY_CONSTRAINT)+1,IRBE3(1,MY_CONSTRAINT)+IRBE3(5,MY_CONSTRAINT)
696C
697C VARNAME: variable name in ref.extract (without blanks)
698 WRITE(VARNAME,'(a,i0)') 'lrbe3s_',I
699 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),LRBE3(I+IADS),0.0_8)
700 END DO
701C
702 DO I=IRBE3(1,MY_CONSTRAINT)+1,IRBE3(1,MY_CONSTRAINT)+IRBE3(5,MY_CONSTRAINT)
703C
704 DO II = 1,6
705.AND. IF(FRBE3(II,I) /=ONEFRBE3(II,I) /=ZERO)THEN
706 WRITE(VARNAME,'(a,i1,a,i0)') 'frbe3_',II,'_',I
707 TEMP_DOUBLE = FRBE3(II,I)
708 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
709 END IF
710 END DO !II = 1,6
711 END DO
712C
713 END DO ! MY_CONSTRAINT=1,NRBE3
714 END IF
715C-----------------------------------------------
716C Merge Rigid Bodies
717C-----------------------------------------------
718 IF (MYQAKEY('/merge')) THEN
719 II = 1
720 DO MY_CONSTRAINT=1,NRBMERGE
721C
722 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(30)+MY_CONSTRAINT),LTITR)
723 MY_ID = MGRBY(6,II)
724 IF(LEN_TRIM(TITR)/=0)THEN
725 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
726 ELSE
727 CALL QAPRINT('a_merge_fake_name',MY_ID,0.0_8)
728 END IF
729C
730 DO MY_MERGE=II,SMGRBY
731 IF(MGRBY(6,MY_MERGE) /= MY_ID) THEN
732 II = MY_MERGE
733 EXIT
734 ENDIF
735 DO I=1,NMGRBY
736 IF(MGRBY(I,MY_MERGE) /=0)THEN
737C VARNAME: variable name in ref.extract (without blanks)
738 WRITE(VARNAME,'(a,i0)') 'mgrby_',I
739 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),MGRBY(I,MY_MERGE),0.0_8)
740 END IF
741 END DO
742 END DO ! MY_MERGE=II,SMGRBY
743
744 END DO ! MY_CONSTRAINT=1,NRBMERGE
745 END IF
746C-----------------------------------------------
747C /SPHBCS
748C-----------------------------------------------
749 IF (MYQAKEY('/sphbcs')) THEN
750 DO MY_CONSTRAINT=1,NSPCOND
751CC
752 TITR(1:nchartitle)=''
753 my_id = ispcond(4,my_constraint)
754 IF(len_trim(titr)/=0)THEN
755 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
756 ELSE
757 CALL qaprint('A_SPHBCS_FAKE_NAME',my_id,0.0_8)
758 END IF
759C
760 DO i=1,nispcond
761 IF(ispcond(i,my_constraint)/=0)THEN
762C VARNAME: variable name in ref.extract (without blanks)
763 WRITE(varname,'(A,I0,I0)') 'ISPCOND_',i
764 CALL qaprint(varname(1:len_trim(varname)),ispcond(i,my_constraint),0.0_8)
765 END IF
766C
767 END DO
768C
769 END DO ! MY_CONSTRAINT=1,NSPCOND
770 END IF
771C-----------------------------------------------
772C /RBE2
773C-----------------------------------------------
774 IF (myqakey('/RBE2')) THEN
775 DO my_constraint=1,nrbe2
776C
777 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,my_constraint + inom_opt(13)),ltitr)
778 my_id = irbe2(2,my_constraint)
779 IF(len_trim(titr)/=0)THEN
780 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
781 ELSE
782 CALL qaprint('A_RBE2_FAKE_NAME',my_id,0.0_8)
783 END IF
784C
785 DO i=1,nrbe2l
786 IF(irbe2(i,my_constraint) /=0)THEN
787C
788C VARNAME: variable name in ref.extract (without blanks)
789 WRITE(varname,'(A,I0)') 'IRBE2_',i
790 CALL qaprint(varname(1:len_trim(varname)),irbe2(i,my_constraint),0.0_8)
791 END IF
792 END DO
793C
794 DO i=irbe2(1,my_constraint)+1,irbe2(1,my_constraint)+irbe2(5,my_constraint)
795C
796C VARNAME: variable name in ref.extract (without blanks)
797 WRITE(varname,'(A,I0)') 'LRBE2_',i
798 CALL qaprint(varname(1:len_trim(varname)),lrbe2(i),0.0_8)
799 END DO
800C
801 END DO ! MY_CONSTRAINT=1,NRBE2
802 END IF
803C-----------------------------------------------
804C /MPC
805C-----------------------------------------------
806 IF (myqakey('/MPC')) THEN
807 ii=0
808 DO my_constraint=1,nummpc
809C
810 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,inom_opt(17) + my_constraint),ltitr)
811
812 my_id = nom_opt(1,inom_opt(17)+my_constraint)
813 IF(len_trim(titr)/=0)THEN
814 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
815 ELSE
816 CALL qaprint('A_MPC_FAKE_NAME',my_id,0.0_8)
817 END IF
818C
819 DO i=1,ibmpc(my_constraint)
820
821 IF(ibmpc2(ii+i) /=0)THEN
822C VARNAME: variable name in ref.extract (without blanks)
823 WRITE(varname,'(A,I0)') 'nod_',I
824 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IBMPC2(II+I),0.0_8)
825 END IF
826
827 IF(IBMPC3(II+I) /=0)THEN
828C VARNAME: variable name in ref.extract (without blanks)
829 WRITE(VARNAME,'(a,i0)') 'idof_',I
830 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IBMPC3(II+I),0.0_8)
831 END IF
832
833 IF(IBMPC4(II+I) /=0)THEN
834C VARNAME: variable name in ref.extract (without blanks)
835 WRITE(VARNAME,'(a,i0)') 'iskew_',I
836 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),IBMPC4(II+I),0.0_8)
837 END IF
838
839 IF(RBMPC(II+I) /=0)THEN
840 WRITE(VARNAME,'(a,i1,a,i0)') 'alpha_',I
841 TEMP_DOUBLE = RBMPC(II+I)
842 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
843 END IF
844
845 END DO
846 II = II + IBMPC(MY_CONSTRAINT)
847C
848 END DO ! MY_CONSTRAINT=1,NUMMPC
849 END IF
850C-----------------------------------------------
851C /CYL_JOINT
852C-----------------------------------------------
853 IF (MYQAKEY('/cyl_joint')) THEN
854C
855 II = 1
856C
857 DO MY_CONSTRAINT=1,NJOINT
858C
859 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(7)+MY_CONSTRAINT),LTITR)
860 MY_ID = NOM_OPT(1,INOM_OPT(7)+MY_CONSTRAINT)
861 IF(LEN_TRIM(TITR)/=0)THEN
862 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
863 ELSE
864 CALL QAPRINT('a_cyljoint_fake_name',MY_ID,0.0_8)
865 END IF
866C
867 NS = LJOINT(II)
868C
869 DO I=1,NS
870 WRITE(VARNAME,'(a,i0)') 'nod_',I
871 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),ITAB(LJOINT(II+I)),0.0_8)
872 ENDDO
873C
874 II=II+NS+1
875C
876 END DO
877 END IF
878C-----------------------------------------------
879C /GJOINT
880C-----------------------------------------------
881 IF (MYQAKEY('/gjoint')) THEN
882C
883 DO MY_CONSTRAINT=1,NGJOINT
884C
885 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(18) + MY_CONSTRAINT),LTITR)
886 MY_ID = NOM_OPT(1,INOM_OPT(18)+MY_CONSTRAINT)
887 IF(LEN_TRIM(TITR)/=0)THEN
888 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
889 ELSE
890 CALL QAPRINT('a_gjoint_fake_name',MY_ID,0.0_8)
891 END IF
892C
893 DO I=1,LKJNI
894 WRITE(VARNAME,'(a,i0)') 'gjbufi_',I
895 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),GJBUFI(I,MY_CONSTRAINT),0.0_8)
896 ENDDO
897C
898 DO I=1,LKJNR
899 WRITE(VARNAME,'(a,i0)') 'gjbufr_',I
900 TEMP_DOUBLE = GJBUFR(I,MY_CONSTRAINT)
901 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
902 ENDDO
903C
904 DO I=1,4
905 WRITE(VARNAME,'(a,i0)') 'mass_',I
906 IF (GJBUFI(2+I,MY_CONSTRAINT) > 0) THEN
907 TEMP_DOUBLE = MS(GJBUFI(2+I,MY_CONSTRAINT))
908 ELSE
909 TEMP_DOUBLE = ZERO
910 ENDIF
911 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
912 ENDDO
913C
914 DO I=1,4
915 WRITE(VARNAME,'(a,i0)') 'iner_',I
916 IF (GJBUFI(2+I,MY_CONSTRAINT) > 0) THEN
917 TEMP_DOUBLE = IN(GJBUFI(2+I,MY_CONSTRAINT))
918 ELSE
919 TEMP_DOUBLE = ZERO
920 ENDIF
921 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),0,TEMP_DOUBLE)
922 ENDDO
923C
924 END DO
925 END IF
926C-----------------------------------------------
927C RLINK
928C-----------------------------------------------
929 IF (MYQAKEY('/rlink')) THEN
930C
931 IF (NLINK > 0) THEN
932C
933C
934 DO MY_CONSTRAINT = 1, NLINK
935c
936 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(9)+MY_CONSTRAINT),LTITR)
937 MY_ID = NOM_OPT(1,INOM_OPT(9)+MY_CONSTRAINT)
938 IF(LEN_TRIM(TITR)/=0)THEN
939 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
940 ELSE
941 CALL QAPRINT('a_rlink_name',MY_ID,0.0_8)
942 END IF
943c
944 DO I = 1,10
945 IF(NNLINK(I,MY_CONSTRAINT) /=0)THEN
946 WRITE(VARNAME,'(a,i0)') 'nnlink_',I
947 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),NNLINK(I,MY_CONSTRAINT),0.0_8)
948 END IF
949 ENDDO
950c
951 ENDDO
952 DO I = 1,SLNLINK
953 IF(LNLINK(I) /=0)THEN
954 WRITE(VARNAME,'(a,i0)') 'lnlink_',I
955 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),LNLINK(I),0.0_8)
956 END IF
957 ENDDO
958
959
960 ENDIF
961 END IF
962C-----------------------------------------------
963C /ALE/LINK
964C-----------------------------------------------
965 IF (MYQAKEY('/ale/link')) THEN
966 DO II = 1, LLINAL
967 WRITE(VARNAME,'(a,i0)') 'linale_', II
968 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),LINALE(II),0.0_8)
969 ENDDO
970 ENDIF
971C-----------------------------------------------
972C /FXBODY
973C-----------------------------------------------
974 IF (MYQAKEY('/fxbody')) THEN
975 IF (NFXBODY > 0) THEN
976C
977! Sort by ID to ensure internal order independent output
978 DO I = 1, NFXBODY
979 IDSFX(I) = FXBIPM(1,I)
980 IDXFX(I) = I
981 ENDDO
982 CALL QUICKSORT_I2(IDSFX, IDXFX, 1, NFXBODY)
983C
984! Loop over FXBODY
985 DO II = 1,NFXBODY
986C
987 MY_FXBODY = IDXFX(II)
988 TITR(1:nchartitle)=''
989 CALL FRETITL2(TITR,NOM_OPT(LNOPT1-LTITR+1,INOM_OPT(11)+MY_FXBODY),LTITR)
990 MY_ID = NOM_OPT(1,INOM_OPT(11)+MY_FXBODY)
991 IF (LEN_TRIM(TITR) /= 0) THEN
992 CALL QAPRINT(TITR(1:LEN_TRIM(TITR)),MY_ID,0.0_8)
993 ELSE
994 CALL QAPRINT('a_fxbody_fake_name',MY_ID,0.0_8)
995 END IF
996C
997 DO I = 1,NBIPM
998 IF (FXBIPM(I,MY_FXBODY) /= 0) THEN
999 WRITE(VARNAME,'(a,i0)') 'fxbipm_',I
1000 CALL QAPRINT(VARNAME(1:LEN_TRIM(VARNAME)),FXBIPM(I,MY_FXBODY),0.0_8)
1001 ENDIF
1002 ENDDO
1003C
1004 CALL QAPRINT('fxbody_file_name',0,0.0_8)
1005 CALL QAPRINT(FXBFILE_TAB(MY_FXBODY)(1:LEN_TRIM(FXBFILE_TAB(MY_FXBODY))),0,0.0_8)
1006C
1007 ENDDO
1008 ENDIF
1009 ENDIF
1010C-----------------------------------------------
1011 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
merge
subroutine merge(x, itab, itabm1, cmerge, imerge, imerge2, iadmerge2, nmerge_tot)
Definition merge.F:36
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
qa_out_mod
Definition qa_out_mod.F:78
qa_out_mod::myqakey
logical function myqakey(value)
@purpose Check if a given value is part of the values set by env variable Useful to make a condition ...
Definition qa_out_mod.F:694
qa_out_mod::qaprint
subroutine qaprint(name, idin, value)
@purpose print one entry to QA extract file example of call for real print CALL QAPRINT('MY_LABEL',...
Definition qa_out_mod.F:390
r2r_mod
Definition r2r_mod.F:125
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799