OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_constraints.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| st_qaprint_constraints ../starter/source/output/qaprint/st_qaprint_constraints.F
25!||--- called by ------------------------------------------------------
26!|| st_qaprint_driver ../starter/source/output/qaprint/st_qaprint_driver.F
27!||--- calls -----------------------------------------------------
28!|| fretitl2 ../starter/source/starter/freform.F
29!||--- uses -----------------------------------------------------
30!|| r2r_mod ../starter/share/modules1/r2r_mod.F
31!||====================================================================
32 SUBROUTINE st_qaprint_constraints(NOM_OPT ,INOM_OPT ,NPBY ,LPBY ,RBY ,
33 2 IBFTEMP ,FBFTEMP ,IBFFLUX ,FBFFLUX ,ITAB ,
34 3 ICODE ,ISKEW ,IBCSLAG ,IBFVEL ,FBFVEL ,
35 4 NIMPDISP ,NIMPVEL ,NIMPACC ,RWBUF ,NPRW ,
36 5 LPRW ,IBCSCYC ,IRBE3 ,LRBE3 ,FRBE3 ,
37 6 MGRBY ,ISPCOND ,IRBE2 ,LRBE2 ,NPBYL ,
38 7 LPBYL ,RBYL ,IBMPC ,IBMPC2 ,IBMPC3 ,
39 8 IBMPC4 ,RBMPC ,LJOINT ,NNLINK ,LNLINK,
40 9 LLINAL ,LINALE ,GJBUFI ,GJBUFR ,MS ,
41 9 IN ,FXBIPM ,FXBFILE_TAB,GLOB_THERM)
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 IF(frbe3(ii,i) /=one.AND.frbe3(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
1012 END
my_real
#define my_real
Definition cppsort.cpp:32
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
quicksort_i2
recursive subroutine quicksort_i2(a, idx, first, last)
Definition quicksort.F:153
st_qaprint_constraints
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)
Definition st_qaprint_constraints.F:42
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799