OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
st_qaprint_loads.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "scr03_c.inc"
#include "scr17_c.inc"
#include "tabsiz_c.inc"
#include "boltpr_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine st_qaprint_loads (nom_opt, inom_opt, numloadp, iloadp, lloadp, loadp, ibcl, forc, ipres, pres, ibcr, fradia, ibcv, fconv, igrv, lgrv, agrv, icfield, lcfield, cfield, ipreload, preload, iflag_bpreload, liflow, lrflow, iflow, rflow, isphio, vsphio, glob_therm, pblast)

Function/Subroutine Documentation

◆ st_qaprint_loads()

subroutine st_qaprint_loads ( integer, dimension(lnopt1,snom_opt1), intent(in) nom_opt,
integer, dimension(sinom_opt), intent(in) inom_opt,
integer, intent(in) numloadp,
integer, dimension(sizloadp,nloadp), intent(in) iloadp,
integer, dimension(numloadp), intent(in) lloadp,
dimension(lfacload,nloadp), intent(in) loadp,
integer, dimension(nibcld,nconld-npreld), intent(in) ibcl,
dimension(lfaccld,nconld-npreld), intent(in) forc,
integer, dimension(nibcld,npreld), intent(in) ipres,
dimension(lfaccld,npreld), intent(in) pres,
integer, dimension(glob_therm%niradia,glob_therm%numradia), intent(in) ibcr,
dimension(glob_therm%lfacther,glob_therm%numradia), intent(in) fradia,
integer, dimension(glob_therm%niconv,glob_therm%numconv), intent(in) ibcv,
dimension(glob_therm%lfacther,glob_therm%numconv), intent(in) fconv,
integer, dimension(nigrv,ngrav), intent(in) igrv,
integer, dimension(*), intent(in) lgrv,
dimension(lfacgrv,ngrav), intent(in) agrv,
integer, dimension(sizfield,nloadc), intent(in) icfield,
integer, dimension(slcfield), intent(in) lcfield,
dimension(lfacload,nloadc), intent(in) cfield,
integer, dimension(3,*), intent(in) ipreload,
dimension(6,*), intent(in) preload,
integer, dimension(numels), intent(in) iflag_bpreload,
integer, intent(in) liflow,
integer, intent(in) lrflow,
integer, dimension(liflow), intent(in) iflow,
intent(in) rflow,
integer, dimension(nisphio,nsphio) isphio,
vsphio,
type (glob_therm_), intent(in) glob_therm,
type (pblast_), intent(in) pblast )

Definition at line 31 of file st_qaprint_loads.F.

38C============================================================================
39C M o d u l e s
40C-----------------------------------------------
41 USE qa_out_mod
42 USE names_and_titles_mod , ONLY : nchartitle
43 use glob_therm_mod
44 USE pblast_mod
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "com01_c.inc"
53#include "com04_c.inc"
54#include "param_c.inc"
55#include "scr03_c.inc"
56#include "scr17_c.inc"
57#include "tabsiz_c.inc"
58#include "boltpr_c.inc"
59#include "sphcom.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER, INTENT(IN) :: NOM_OPT(LNOPT1,SNOM_OPT1), INOM_OPT(SINOM_OPT)
64C-----------------------------------------------
65C NOM_OPT(LNOPT1,SNOM_OPT1)
66C * Possibly, NOM_OPT(1) = ID
67C NOM_OPT(LNOPT1-LTITL+1:LTITL) <=> TITLES of the OPTIONS
68C--------------------------------------------------
69C SNOM_OPT1= NRBODY+NACCELM+NVOLU+NINTER+NINTSUB+
70C + NRWALL+NJOINT+NSECT+NLINK+
71C + NUMSKW+1+NUMFRAM+1+NFXBODY+NFLOW+NRBE2+
72C + NRBE3+NSUBMOD+NFXVEL+NUMBCS+NUMMPC+
73C + NGJOINT+NUNIT0+NFUNCT+NADMESH+
74C + NSPHIO+NSPCOND+NRBYKIN+NEBCS+
75C + NINICRACK+NODMAS+NBGAUGE+NCLUSTER+NINTERFRIC+
76C + NRBMERGE
77C-----------------------------------------------
78C INOM_OPT(SINOM_OPT)
79C--------------------------------------------------
80C INOM_OPT(1) = NRBODY
81C INOM_OPT(2) = INOM_OPT(1) + NACCELM
82C INOM_OPT(3) = INOM_OPT(2) + NVOLU
83C INOM_OPT(4) = INOM_OPT(3) + NINTER
84C INOM_OPT(5) = INOM_OPT(4) + NINTSUB
85C INOM_OPT(6) = INOM_OPT(5) + NRWALL
86C INOM_OPT(7) = INOM_OPT(6)
87C INOM_OPT(8) = INOM_OPT(7) + NJOINT
88C INOM_OPT(9) = INOM_OPT(8) + NSECT
89C INOM_OPT(10)= INOM_OPT(9) + NLINK
90C INOM_OPT(11)= INOM_OPT(10)+ NUMSKW+1+NUMFRAM+1+NSUBMOD
91C INOM_OPT(12)= INOM_OPT(11)+ NFXBODY
92C INOM_OPT(13)= INOM_OPT(12)+ NFLOW
93C INOM_OPT(14)= INOM_OPT(13)+ NRBE2
94C INOM_OPT(15)= INOM_OPT(14)+ NRBE3
95C INOM_OPT(16)= INOM_OPT(15)+ NFXVEL
96C INOM_OPT(17)= INOM_OPT(16)+ NUMBCS
97C INOM_OPT(18)= INOM_OPT(17)+ NUMMPC
98C INOM_OPT(19)= INOM_OPT(18)+ NGJOINT
99C INOM_OPT(20)= INOM_OPT(19)+ NUNIT0
100C INOM_OPT(21)= INOM_OPT(20)+ NFUNCT
101C INOM_OPT(22)= INOM_OPT(21)+ NADMESH
102C INOM_OPT(23)= INOM_OPT(22)+ NSPHIO
103C INOM_OPT(24)= INOM_OPT(23)+ NSPCOND
104C INOM_OPT(25)= INOM_OPT(24)+ NEBCS
105C INOM_OPT(26)= INOM_OPT(25)+ NINICRACK
106C INOM_OPT(27)= INOM_OPT(26)+ NODMAS
107C INOM_OPT(28)= INOM_OPT(27)+ NBGAUGE
108C INOM_OPT(29)= INOM_OPT(28)+ NCLUSTER
109C INOM_OPT(30)= INOM_OPT(29)+ NINTERFRIC
110C INOM_OPT(31)= INOM_OPT(30)+ NRBMERGE
111C .. TO BE MAINTAINED (cf doc/inom_opt.txt) ..
112C-----------------------------------------------
113 TYPE (glob_therm_) ,intent(in) :: glob_therm
114 TYPE (PBLAST_) ,intent(in) :: PBLAST
115 INTEGER, INTENT(IN) :: NUMLOADP, ILOADP(SIZLOADP,NLOADP), LLOADP(NUMLOADP)
116 INTEGER, INTENT(IN) :: ICFIELD(SIZFIELD,NLOADC), LCFIELD(SLCFIELD)
117 INTEGER, INTENT(IN) :: IBCL(NIBCLD,NCONLD-NPRELD), IPRES(NIBCLD,NPRELD)
118 INTEGER, INTENT(IN) :: IBCR(GLOB_THERM%NIRADIA,GLOB_THERM%NUMRADIA)
119 INTEGER, INTENT(IN) :: IBCV(GLOB_THERM%NICONV,GLOB_THERM%NUMCONV)
120 INTEGER, INTENT(IN) :: IGRV(NIGRV,NGRAV), LGRV(*)
121 INTEGER, INTENT(IN) :: IPRELOAD(3,*), IFLAG_BPRELOAD(NUMELS)
122 my_real, INTENT(IN) ::
123 . loadp(lfacload,nloadp), cfield(lfacload,nloadc),
124 . forc(lfaccld,nconld-npreld), pres(lfaccld,npreld),
125 . agrv(lfacgrv,ngrav),preload(6,*)
126 my_real, INTENT(IN) :: fradia(glob_therm%LFACTHER,glob_therm%NUMRADIA)
127 my_real, INTENT(IN) :: fconv(glob_therm%LFACTHER,glob_therm%NUMCONV)
128 INTEGER, INTENT(IN) :: LIFLOW, LRFLOW
129 INTEGER, DIMENSION(LIFLOW), INTENT(IN) :: IFLOW
130 my_real, DIMENSION(LRFLOW), INTENT(IN) :: rflow
131 INTEGER ISPHIO(NISPHIO,NSPHIO)
132 my_real
133 . vsphio(svsphio)
134C--------------------------------------------------
135C L o c a l V a r i a b l e s
136C-----------------------------------------------
137 INTEGER I,IPRE, MY_ID, MY_LOAD,J,
138 . IDS(NSPHIO),IDX(NSPHIO),II,MY_SPHIO,LVAD(NSPHIO),
139 . FIRST,LAST
140 CHARACTER(LEN=NCHARTITLE) :: TITR
141 CHARACTER (LEN=255) :: VARNAME
142 DOUBLE PRECISION TEMP_DOUBLE
143 LOGICAL :: OK_QA
144 INTEGER :: COUNT,IOPT_FIRST,IOPT_LAST
145C-----------------------------------------------
146C /LOAD/CENTRI
147C-----------------------------------------------
148 IF (myqakey('/LOAD/CENTRI')) THEN
149 DO my_load=1,nloadc
150C
151C Title of the option was not stored in NOM_OPT ... TBD
152 titr(1:nchartitle)=''
153 IF(len_trim(titr)/=0)THEN
154 CALL qaprint(titr(1:len_trim(titr)),icfield(9,my_load),0.0_8)
155 ELSE
156 CALL qaprint('A_LOAD_CENTRI_FAKE_NAME',icfield(9,my_load),0.0_8)
157 END IF
158C
159 DO i=1,sizfield
160 IF(icfield(i,my_load) /=0)THEN
161C
162C VARNAME: variable name in ref.extract (without blanks)
163 WRITE(varname,'(A,I0)') 'ICFIELD_',i ! ICFIELD(11) => 'ICFIELD_11'
164 CALL qaprint(varname(1:len_trim(varname)),icfield(i,my_load),0.0_8)
165 END IF
166 END DO
167C
168 DO i=icfield(4,my_load),icfield(4,my_load)+icfield(1,my_load)-1
169C
170C VARNAME: variable name in ref.extract (without blanks)
171 WRITE(varname,'(A,I0)') 'LCFIELD_',i ! LCFIELD(11) => 'LCFIELD_11'
172 CALL qaprint(varname(1:len_trim(varname)),lcfield(i),0.0_8)
173 END DO
174C
175 DO i=1,lfacload
176 IF(cfield(i,my_load)/=zero)THEN
177C
178C VARNAME: variable name in ref.extract (without blanks)
179 WRITE(varname,'(A,I0)') 'CFIELD_',i
180 temp_double = cfield(i,my_load)
181 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
182 END IF
183 END DO
184C
185 END DO ! MY_LOAD=1,NLOADC
186 END IF
187C-----------------------------------------------
188C /LOAD/PFLUID & /LOAD/PBLAST & /LOAD/PRESSURE
189C-----------------------------------------------
190 ok_qa = myqakey('/LOAD/PFLUID') .OR. myqakey('/LOAD/PBLAST') .OR. myqakey('/LOAD/PRESSURE')
191
192 IF (ok_qa) THEN
193 !output pressure only
194 iopt_first = 0
195 iopt_last = 0
196 IF(myqakey('/LOAD/PFLUID'))THEN
197 !output pfluid only
198 iopt_first = 1
199 iopt_last = nloadp_f
200 ELSEIF(myqakey('/LOAD/PBLAST'))THEN
201 !output pblast only
202 iopt_first = 1+nloadp_f
203 iopt_last = nloadp_f+pblast%NLOADP_B
204 ELSEIF(myqakey('/LOAD/PRESSURE'))THEN
205 !output pressure only
206 iopt_first = 1+nloadp_f+pblast%NLOADP_B
207 iopt_last = nloadp_f+pblast%NLOADP_B+nloadp_hyd
208 ENDIF
209
210 !common procedure for /LOAD/PFLUID, /LOAD/PBLAST, /LOAD/PRESSURE options.
211 DO my_load=iopt_first,iopt_last
212C
213C Title of the option was not stored in NOM_OPT ... TBD
214 titr(1:nchartitle)=''
215 IF(len_trim(titr)/=0)THEN
216 CALL qaprint(titr(1:len_trim(titr)),iloadp(2,my_load),0.0_8)
217 ELSE
218 CALL qaprint('A_LOAD_PFLUID_FAKE_NAME',iloadp(2,my_load),0.0_8)
219 END IF
220C
221 DO i=1,sizloadp
222 IF(iloadp(i,my_load) /=0)THEN
223C
224C VARNAME: variable name in ref.extract (without blanks)
225 WRITE(varname,'(A,I0)') 'ILOADP_',i ! ILOADP(11) => 'ILOADP_11'
226 CALL qaprint(varname(1:len_trim(varname)),iloadp(i,my_load),0.0_8)
227 END IF
228 END DO
229
230 DO i=1,lfacload
231 IF(loadp(i,my_load)/=zero)THEN
232C
233C VARNAME: variable name in ref.extract (without blanks)
234 WRITE(varname,'(A,I0)') 'LOADP_',i
235 temp_double = loadp(i,my_load)
236 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
237 END IF
238 END DO
239
240 first=iloadp(4,my_load)
241 last=iloadp(4,my_load)+iloadp(1,my_load)-1
242
243 IF(last-first+1 <= 10 )THEN
244 !display all segments
245 DO i=first,last
246C VARNAME: variable name in ref.extract (without blanks)
247 WRITE(varname,'(A,I0)') 'LLOADP_',i ! LLOADP(11) => 'LLOADP_11'
248 CALL qaprint(varname(1:len_trim(varname)),lloadp(i),0.0_8)
249 END DO
250 ELSE
251 !display only 5 first ones and 5 last ones
252 !first 5 segments
253 first=iloadp(4,my_load)
254 last=first+5
255 DO i=first,last
256C VARNAME: variable name in ref.extract (without blanks)
257 WRITE(varname,'(A,I0)') 'LLOADP_',i ! lloadp(11) => 'LLOADP_11'
258 CALL qaprint(varname(1:len_trim(varname)),lloadp(i),0.0_8)
259 END DO
260 !suspension points '...'
261 CALL qaprint('...',0,0.0_8)
262 !last 5 segments
263 last=iloadp(4,my_load)+iloadp(1,my_load)-1
264 first=last-5
265 DO i=first,last
266C VARNAME: variable name in ref.extract (without blanks)
267 WRITE(varname,'(A,I0)') 'LLOADP_',i ! LLOADP(11) => 'LLOADP_11'
268 CALL qaprint(varname(1:len_trim(varname)),lloadp(i),0.0_8)
269 END DO
270 ENDIF
271C
272 END DO ! MY_LOAD=IOPT_FIRST, IOPT_LAST
273 END IF
274
275C-----------------------------------------------
276C /CLOAD
277C-----------------------------------------------
278 IF (myqakey('/CLOAD')) THEN
279 DO my_load=1,nconld-npreld
280C
281C Title of the option was not stored in NOM_OPT ... TBD
282C and Cload ID is not stored
283 titr(1:nchartitle)=''
284 IF(len_trim(titr)/=0)THEN
285 CALL qaprint(titr(1:len_trim(titr)),my_load,0.0_8)
286 ELSE
287 CALL qaprint('A_CLOAD_FAKE_NAME',my_load,0.0_8)
288 END IF
289C
290 DO i=1,nibcld
291 IF(ibcl(i,my_load) /=0)THEN
292C
293C VARNAME: variable name in ref.extract (without blanks)
294 WRITE(varname,'(A,I0)') 'IBCL_',i ! IBCL(11) => 'IBCL_11'
295 CALL qaprint(varname(1:len_trim(varname)),ibcl(i,my_load),0.0_8)
296 END IF
297 END DO
298C
299 DO i=1,lfaccld
300 IF(forc(i,my_load)/=zero)THEN
301C
302C VARNAME: variable name in ref.extract (without blanks)
303 WRITE(varname,'(A,I0)') 'FORC_',i
304 temp_double = forc(i,my_load)
305 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
306 END IF
307 END DO
308C
309 END DO ! MY_LOAD=1,NCONLD-NPRELD
310 END IF
311C-----------------------------------------------
312C /PLOAD
313C-----------------------------------------------
314 IF (myqakey('/PLOAD')) THEN
315 DO my_load=1,npreld
316C
317C Title of the option was not stored in NOM_OPT ... TBD
318C and Pload ID is not stored
319 titr(1:nchartitle)=''
320 IF(len_trim(titr)/=0)THEN
321 CALL qaprint(titr(1:len_trim(titr)),my_load,0.0_8)
322 ELSE
323 CALL qaprint('A_PLOAD_FAKE_NAME',my_load,0.0_8)
324 END IF
325C
326 DO i=1,nibcld
327 IF(ipres(i,my_load) /=0)THEN
328C
329C VARNAME: variable name in ref.extract (without blanks)
330 WRITE(varname,'(A,I0)') 'IPRES_',i ! IPRES(11) => 'IPRES_11'
331 CALL qaprint(varname(1:len_trim(varname)),ipres(i,my_load),0.0_8)
332 END IF
333 END DO
334C
335 DO i=1,lfaccld
336 IF(pres(i,my_load)/=zero)THEN
337C
338C VARNAME: variable name in ref.extract (without blanks)
339 WRITE(varname,'(A,I0)') 'PRES_',i
340 temp_double = pres(i,my_load)
341 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
342 END IF
343 END DO
344C
345 END DO ! MY_LOAD=1,NPRELD
346 END IF
347C-----------------------------------------------
348C /RADIATION
349C-----------------------------------------------
350 IF (myqakey('/RADIATION')) THEN
351 DO my_load=1,glob_therm%NUMRADIA
352C
353C Title of the option was not stored in NOM_OPT ... TBD
354C and Radiation ID is not stored
355 titr(1:nchartitle)=''
356 IF(len_trim(titr)/=0)THEN
357 CALL qaprint(titr(1:len_trim(titr)),my_load,0.0_8)
358 ELSE
359 CALL qaprint('A_RADIATION_FAKE_NAME',my_load,0.0_8)
360 END IF
361C
362 DO i=1,glob_therm%NIRADIA
363 IF(ibcr(i,my_load) /=0)THEN
364C
365C VARNAME: variable name in ref.extract (without blanks)
366 WRITE(varname,'(A,I0)') 'IBCR_',i ! IBCR(11) => 'IBCR_11'
367 CALL qaprint(varname(1:len_trim(varname)),ibcr(i,my_load),0.0_8)
368 END IF
369 END DO
370C
371 DO i=1,glob_therm%LFACTHER
372 IF(fradia(i,my_load)/=zero)THEN
373C
374C VARNAME: variable name in ref.extract (without blanks)
375 WRITE(varname,'(A,I0)') 'FRADIA_',i
376 temp_double = fradia(i,my_load)
377 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
378 END IF
379 END DO
380C
381 END DO ! MY_LOAD=1,NUMRADIA
382 END IF
383C-----------------------------------------------
384C /CONVEC
385C-----------------------------------------------
386 IF (myqakey('/CONVEC')) THEN
387 DO my_load=1,glob_therm%NUMCONV
388C
389C Title of the option was not stored in NOM_OPT ... TBD
390C and Convev ID is not stored
391 titr(1:nchartitle)=''
392 IF(len_trim(titr)/=0)THEN
393 CALL qaprint(titr(1:len_trim(titr)),my_load,0.0_8)
394 ELSE
395 CALL qaprint('A_CONVEC_FAKE_NAME',my_load,0.0_8)
396 END IF
397C
398 DO i=1,glob_therm%NICONV
399 IF(ibcv(i,my_load) /=0)THEN
400C
401C VARNAME: variable name in ref.extract (without blanks)
402 WRITE(varname,'(A,I0)') 'IBCV_',i ! IBCV(11) => 'IBCV_11'
403 CALL qaprint(varname(1:len_trim(varname)),ibcv(i,my_load),0.0_8)
404 END IF
405 END DO
406C
407 DO i=1,glob_therm%LFACTHER
408 IF(fconv(i,my_load)/=zero)THEN
409C
410C VARNAME: variable name in ref.extract (without blanks)
411 WRITE(varname,'(A,I0)') 'FCONV_',i
412 temp_double = fconv(i,my_load)
413 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
414 END IF
415 END DO
416C
417 END DO ! MY_LOAD=1,NUMCONV
418 END IF
419C-----------------------------------------------
420C /GRAV
421C-----------------------------------------------
422 IF (myqakey('/GRAV')) THEN
423 DO my_load=1,ngrav
424C
425C Title of the option was not stored in NOM_OPT ... TBD
426 titr(1:nchartitle)=''
427 my_id=igrv(5,my_load)
428 IF(len_trim(titr)/=0)THEN
429 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
430 ELSE
431 CALL qaprint('A_GRAVITY_FAKE_NAME',my_id,0.0_8)
432 END IF
433C
434 DO i=1,nigrv
435 IF(igrv(i,my_load) /=0)THEN
436C
437C VARNAME: variable name in ref.extract (without blanks)
438 WRITE(varname,'(A,I0)') 'IGRV_',i ! IGRV(11) => 'IGRV_11'
439 CALL qaprint(varname(1:len_trim(varname)),igrv(i,my_load),0.0_8)
440 END IF
441 END DO
442C
443 DO i=igrv(4,my_load),igrv(4,my_load)+igrv(1,my_load)-1
444C
445C VARNAME: variable name in ref.extract (without blanks)
446 WRITE(varname,'(A,I0)') 'LGRV_',i
447 CALL qaprint(varname(1:len_trim(varname)),lgrv(i),0.0_8)
448 END DO
449C
450 DO i=1,lfacgrv
451 IF(agrv(i,my_load)/=zero)THEN
452C
453C VARNAME: variable name in ref.extract (without blanks)
454 WRITE(varname,'(A,I0)') 'AGRV_',i
455 temp_double = agrv(i,my_load)
456 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
457 END IF
458 END DO
459C
460 END DO ! MY_LOAD=1,NGRAV
461 END IF
462C-----------------------------------------------
463C /PRELOAD
464C-----------------------------------------------
465 IF (myqakey('/PRELOAD')) THEN
466C
467 ! ID of /PRELOAD is not stored and so not retrieved
468 IF (npreload > 0) THEN
469
470 DO ipre = 1,numpreload
471c
472 titr(1:nchartitle)=''
473 IF(len_trim(titr)/=0)THEN
474 CALL qaprint(titr(1:len_trim(titr)),ipre,0.0_8)
475 ELSE
476 CALL qaprint('PRELOAD_FAKE_NAME',ipre,0.0_8)
477 END IF
478c
479 DO j = 1 , 3
480 IF(ipreload(j,ipre) /=0)THEN
481 WRITE(varname,'(A,I0,I0)') 'IPRELOAD_',j,ipre
482 CALL qaprint(varname(1:len_trim(varname)),ipreload(j,ipre),0.0_8)
483 END IF
484 ENDDO
485c
486 IF(ipreload(1,ipre) /=0)THEN
487 j = ipreload(1,ipre)
488 IF(iflag_bpreload(j) /=0)THEN ! this table is used in PRELOAD but modified in sgrhead and SGRTAILS
489 WRITE(varname,'(A,I0)') 'IFLAG_BPRELOAD_',j
490 CALL qaprint(varname(1:len_trim(varname)),iflag_bpreload(j),0.0_8)
491 END IF
492 END IF
493c
494 DO j = 1 , 6
495 IF(preload(j,ipre)/=zero)THEN
496 WRITE(varname,'(A,I0,I0)') 'PRELOAD_',j,ipre
497 temp_double = preload(j,ipre)
498 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
499 END IF
500 ENDDO
501c
502 ENDDO
503 ENDIF
504 ENDIF
505
506C /BEM/DAA and /BEM/FLOW
507 ok_qa = myqakey('/BEM') .AND. nflow > 0
508 IF (ok_qa) THEN
509 WRITE(varname, '(A)') "LIFLOW_=_"
510 CALL qaprint(varname(1:len_trim(varname)), liflow, 0.0_8)
511 WRITE(varname, '(A)') "LRFLOW_=_"
512 CALL qaprint(varname(1:len_trim(varname)), lrflow, 0.0_8)
513 count = 0
514 DO i = 1, liflow
515 WRITE(varname, '(A, I0)') "IFLOW ", i
516 IF (iflow(i) /= 0) THEN
517 count = count + 1
518 CALL qaprint(varname(1:len_trim(varname)), iflow(i), 0.0_8)
519 ENDIF
520 IF (count == 100) EXIT
521 ENDDO
522 count = 0
523 DO i = liflow, 1, -1
524 WRITE(varname, '(A, I0)') "IFLOW ", i
525 IF (iflow(i) /= 0) THEN
526 count = count + 1
527 CALL qaprint(varname(1:len_trim(varname)), iflow(i), 0.0_8)
528 ENDIF
529 IF (count == 100) EXIT
530 ENDDO
531 count = 0
532 DO i = 1, lrflow
533 WRITE(varname, '(A, I0)') "RFLOW ", i
534 temp_double = rflow(i)
535 IF (temp_double /= 0.0_8) THEN
536 count = count + 1
537 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
538 ENDIF
539 IF (count == 100) EXIT
540 ENDDO
541 count = 0
542 DO i = lrflow, 1, -1
543 WRITE(varname, '(A, I0)') "RFLOW ", i
544 temp_double = rflow(i)
545 IF (temp_double /= 0.0_8) THEN
546 count = count + 1
547 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
548 ENDIF
549 IF (count == 100) EXIT
550 ENDDO
551 ENDIF
552C-----------------------------------------------
553C /SPH/INOUT
554C-----------------------------------------------
555 IF (myqakey('/SPH/INOUT')) THEN
556 IF (nsphio > 0) THEN
557C
558! Sort by ID to ensure internal order independent output
559 DO i = 1, nsphio
560 ids(i) = isphio(nisphio,i)
561 idx(i) = i
562 IF (i /= nsphio) THEN
563 lvad(i) = isphio(4,i+1) - isphio(4,i)
564 ELSE
565 lvad(i) = svsphio - isphio(4,i)
566 ENDIF
567 ENDDO
568 CALL quicksort_i2(ids, idx, 1, nsphio)
569C
570! Loop over /SPH/INOUT
571 DO ii = 1,nsphio
572C
573 my_sphio = idx(ii)
574 titr(1:nchartitle)=''
575 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,inom_opt(22) + my_sphio),ltitr)
576 my_id = nom_opt(1,inom_opt(22)+my_sphio)
577 IF (len_trim(titr) /= 0) THEN
578 CALL qaprint(titr(1:len_trim(titr)),my_id,0.0_8)
579 ELSE
580 CALL qaprint('A_SPH_INOUT_FAKE_NAME',my_id,0.0_8)
581 END IF
582C
583 DO i = 1,nisphio
584 IF (isphio(i,my_sphio) /= 0) THEN
585 WRITE(varname,'(A,I0)') 'ISPHIO_',i
586 CALL qaprint(varname(1:len_trim(varname)),isphio(i,my_sphio),0.0_8)
587 END IF
588 END DO
589C
590 DO i = isphio(4,my_sphio),isphio(4,my_sphio)+lvad(my_sphio)-1
591 IF ( vsphio(i) /= zero) THEN
592 WRITE(varname,'(A,I0)') 'VSPHIO_',i
593 temp_double = vsphio(i)
594 CALL qaprint(varname(1:len_trim(varname)),0,temp_double)
595 END IF
596 ENDDO
597C
598 END DO ! MY_LOAD=1,NGRAV
599 ENDIF
600 END IF
601
602C-----------------------------------------------
603
604C-----------------------------------------------
605
606 RETURN
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
quicksort_i2
recursive subroutine quicksort_i2(a, idx, first, last)
Definition quicksort.F:153
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799