OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hist1.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "scr05_c.inc"
#include "scr13_c.inc"
#include "scrfs_c.inc"
#include "chara_c.inc"
#include "titr_c.inc"
#include "scr07_c.inc"
#include "scr17_c.inc"
#include "sysunit.inc"
#include "rad2r_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hist1 (filnam, ifil, nthgrp2, long, pm, geo, ipart, subset, ithgrp, ithbuf, igeo, ipm, iparth, nparth, nvparth, nvsubth, ittyp, ithflag, ithvar, ifiltitl, sithbuf, names_and_titles)

Function/Subroutine Documentation

◆ hist1()

subroutine hist1 ( character filnam,
integer ifil,
integer nthgrp2,
integer long,
pm,
geo,
integer, dimension(lipart1,*) ipart,
type (subset_), dimension(nsubs) subset,
integer, dimension(nithgr,*) ithgrp,
integer, dimension(sithbuf), intent(in) ithbuf,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(nparth,*) iparth,
integer nparth,
integer nvparth,
integer nvsubth,
integer ittyp,
integer ithflag,
integer, dimension(*) ithvar,
integer ifiltitl,
integer, intent(in) sithbuf,
type(names_and_titles_), intent(in) names_and_titles )
Parameters
[in]names_and_titlesNAMES_AND_TITLES host the input deck names and titles for outputs

Definition at line 44 of file hist1.F.

50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE groupdef_mod
54 USE inoutfile_mod
55 USE th_mod
56 USE names_and_titles_mod, only:names_and_titles_,ltitle
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "com04_c.inc"
65#include "units_c.inc"
66#include "param_c.inc"
67#include "scr05_c.inc"
68#include "scr13_c.inc"
69#include "scrfs_c.inc"
70#include "chara_c.inc"
71#include "titr_c.inc"
72#include "scr07_c.inc"
73#include "scr17_c.inc"
74#include "sysunit.inc"
75#include "rad2r_c.inc"
76#include "tabsiz_c.inc"
77C-----------------------------------------------
78C D u m m y A r g u m e n t s
79C-----------------------------------------------
80 INTEGER,INTENT(IN) :: SITHBUF ! Size of ithbuf
81 INTEGER,INTENT(IN), DIMENSION(SITHBUF) :: ITHBUF ! Time history buffer
82 INTEGER
83 . IPART(LIPART1,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
84 . ITHGRP(NITHGR,*), IFIL,
85 . NTHGRP2, LONG,
86 . NPARTH,IPARTH(NPARTH,*),NVPARTH,NVSUBTH,
87 . ITTYP,ITHFLAG,ITHVAR(*),IFILTITL
88C REAL
89 my_real
90 . pm(npropm,*),geo(npropg,*)
91 CHARACTER FILNAM*100
92 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
93 TYPE(NAMES_AND_TITLES_),INTENT(IN) :: NAMES_AND_TITLES !< NAMES_AND_TITLES host the input deck names and titles for outputs
94C-----------------------------------------------
95C L o c a l V a r i a b l e s
96C-----------------------------------------------
97 REAL R4
98 INTEGER ITITLE(100), IFILNAM(100), ICODE, I, NJOINV, NRBAGV,
99 . NG, II, N, IH, ITY, NEL, NFT, K, MTN, NACCELV,
100 . IRUNR,NVAR,MID,PID,IAD1,IAD2,J,IAD,LTITL,NRECORD,
101 . SEEK_LOC,IPART1,IPART2
102C REAL
103 my_real
104 . tit40(10),tit80(20),tit100(25)
105 my_real,DIMENSION(20) :: title
106 CHARACTER EOR*8, CH8*8,BLA*7, CH8M*8, CH8L*8, CH8T*8
107 CHARACTER (LEN=LTITLE) :: CARD
108 CHARACTER CH80*80,TITL*100,VAR*10
109 INTEGER :: LEN_TMP_NAME, TITLSUM
110 INTEGER, DIMENSION(20) :: TEXT
111 CHARACTER(len=2148) :: TMP_NAME
112 INTEGER, dimension(:), allocatable :: IWA
113C-----------------------------------------------
114C E x t e r n a l F u n c t i o n s
115C-----------------------------------------------
116 CHARACTER STRR*8, STRI*8
117C-----------------------------------------------
118 EXTERNAL strr,stri
119 DATA bla/' '/
120 DATA eor/'ZZZZZEOR'/
121C=======================================================================
122C
123 card(1:ltitle)=names_and_titles%TITLE(1:ltitle)
124C ICODE=3017
125C ICODE=3023
126C ICODE=3030
127 IF(th_vers>=2021)THEN
128 icode=4021
129 ltitl = 100
130 ELSEIF(th_vers>=50)THEN
131 icode=3050
132 ltitl = 100
133 ELSEIF(th_vers>=47)THEN
134 icode=3041
135 ltitl = 80
136 ELSE
137 icode=3040
138 ltitl = 40
139 ENDIF
140C
141 len_tmp_name = outfile_name_len + rootlen+long
142 tmp_name=outfile_name(1:outfile_name_len)//filnam(1:len_trim(filnam))
143C
144 IF(th_titles == 1)
145 . OPEN(unit=ifiltitl,file=tmp_name(1:len_tmp_name)//'_TITLES',
146 . access='SEQUENTIAL',
147 . form='FORMATTED',status='UNKNOWN')
148C
149 IF(ittyp==0)THEN
150 OPEN(unit=iunit,file=tmp_name(1:len_tmp_name),
151 . access='SEQUENTIAL',
152 . form='UNFORMATTED',status='UNKNOWN')
153 ELSEIF(ittyp==1.OR.ittyp==2)THEN
154 OPEN(unit=iunit,file=tmp_name(1:len_tmp_name),
155 . access='SEQUENTIAL',
156 . form='FORMATTED',status='UNKNOWN')
157 ELSEIF(ittyp==3)THEN
158 DO i=1,len_tmp_name
159 ifilnam(i)=ichar(tmp_name(i:i))
160 ENDDO
161 CALL cur_fil_c(ifil)
162 IF(mcheck==0)THEN
163 CALL open_c(ifilnam,len_tmp_name,0)
164
165 ELSE
166 CALL open_c(ifilnam,len_tmp_name,8)
167 RETURN
168 ENDIF
169 ELSEIF(ittyp==4)THEN
170 DO i=1,len_tmp_name
171 ifilnam(i)=ichar(tmp_name(i:i))
172 ENDDO
173 CALL cur_fil_c(ifil)
174 CALL open_c(ifilnam,len_tmp_name,3)
175 ittyp=3
176 ELSEIF(ittyp==5)THEN
177 DO i=1,len_tmp_name
178 ifilnam(i)=ichar(tmp_name(i:i))
179 ENDDO
180 CALL cur_fil_c(ifil)
181 CALL open_c(ifilnam,len_tmp_name,6)
182 ittyp=3
183 ENDIF
184C-------TITRE------------
185 IF(ittyp==0)THEN
186 READ(card,'(20A4)')title
187 WRITE(iunit)icode,title
188 ELSEIF(ittyp==1)THEN
189 ch8=stri(icode)
190 WRITE(iunit,'(A)')filnam(1:rootlen+long)
191 WRITE(iunit,'(2A)')ch8,card(1:72)
192 ELSEIF(ittyp==2)THEN
193 WRITE(iunit,'(2A)')filnam(1:rootlen+long),' FORMAT'
194 WRITE(iunit,'(A,I5,A,I5,A)')eor,1,'I',72,'C'
195 WRITE(iunit,'(I5,A)')icode,card(1:72)
196 ELSEIF(ittyp==3)THEN
197 DO i=1,80
198 ititle(i)=ichar(card(i:i))
199 ENDDO
200 CALL eor_c(84)
201 CALL write_i_c(icode,1)
202 CALL write_c_c(ititle,80)
203 CALL eor_c(84)
204 ENDIF
205C-------ivers date------------
206 CALL my_ctime(ititle)
207 DO i=1,24
208 ch80(i:i)=char(ititle(i))
209 ENDDO
210 ch80(25:33) =' RADIOSS '
211 ch80(34:59) =versio(2)(9:34)
212 ch80(60:80) =cpunam
213 DO i=25,80
214 ititle(i)=ichar(ch80(i:i))
215 ENDDO
216 IF(ittyp==0)THEN
217 READ(ch80,'(20A4)')title
218 WRITE(iunit)title
219 ELSEIF(ittyp==1)THEN
220 WRITE(iunit,'(A)')ch80
221 ELSEIF(ittyp==2)THEN
222 WRITE(iunit,'(2A)')filnam(1:rootlen+long),' FORMAT'
223 WRITE(iunit,'(A,I5,A)')eor,80,'C'
224 WRITE(iunit,'(A)')ch80
225 ELSEIF(ittyp==3)THEN
226 CALL eor_c(80)
227 CALL write_c_c(ititle,80)
228 CALL eor_c(80)
229 ENDIF
230C
231C-------ADDITIONAL RECORDS------------
232 IF(th_vers>=50)THEN
233C
234C NOMBRE DE RECORDS ADDITIONNELS
235 nrecord=2
236 IF(ittyp==0)THEN
237 WRITE(iunit)nrecord
238 ELSEIF(ittyp==1)THEN
239 ch8=stri(nrecord)
240 WRITE(iunit,'(2A)')ch8
241 ELSEIF(ittyp==2)THEN
242 WRITE(iunit,'(A,I5,A)')eor,1,'I'
243 WRITE(iunit,'(I5)')nrecord
244 ELSEIF(ittyp==3)THEN
245 CALL eor_c(4)
246 CALL write_i_c(nrecord,1)
247 CALL eor_c(4)
248 ENDIF
249C
250C 1ER RECORD : LONGUEUR DES TITRES
251 IF(ittyp==0)THEN
252 WRITE(iunit)ltitl
253 ELSEIF(ittyp==1)THEN
254 ch8=stri(ltitl)
255 WRITE(iunit,'(2A)')ch8
256 ELSEIF(ittyp==2)THEN
257 WRITE(iunit,'(A,I5,A)')eor,1,'I'
258 WRITE(iunit,'(I5)')ltitl
259 ELSEIF(ittyp==3)THEN
260 CALL eor_c(4)
261 CALL write_i_c(ltitl,1)
262 CALL eor_c(4)
263 ENDIF
264C
265C 2EME RECORD : FAC_MASS,FAC_LENGTH,FAC_TIME
266 IF(ittyp==0)THEN
267 WRITE(iunit) fac_mass,fac_length,fac_time
268 ELSEIF(ittyp==1)THEN
269 ch8m=strr(fac_mass)
270 ch8l=strr(fac_length)
271 ch8t=strr(fac_time)
272 WRITE(iunit,'(3A8)')ch8m,ch8l,ch8t
273 ELSEIF(ittyp==2)THEN
274 WRITE(iunit,'(A,I5,A)')eor,3,'R'
275 WRITE(iunit,'((5(1X,1PE15.8)))')fac_mass,fac_length,fac_time
276 ELSEIF(ittyp==3)THEN
277 CALL eor_c(12)
278 r4=fac_mass
279 CALL write_r_c(r4,1)
280 r4=fac_length
281 CALL write_r_c(r4,1)
282 r4=fac_time
283 CALL write_r_c(r4,1)
284 CALL eor_c(12)
285 ENDIF
286 END IF
287C-------HIERARCHY INFO------------
288 ALLOCATE(iwa(6))
289 iwa(1)=npart+nthpart
290 iwa(2)=nummat
291 iwa(3)=numgeo
292 iwa(4)=nsubs
293 iwa(5)=nthgrp2
294 IF(nsect==0.AND.nsflsw/=0) iwa(5)=nthgrp2+1
295 IF (th_vers >= 2026)THEN
296 nglobth=16
297 ELSEIF (th_vers >= 2021) THEN
298 nglobth=15
299 ELSE
300 nglobth=12
301 END IF
302c
303 IF (iunit /= iuhis) THEN
304 iwa(6)= 0
305 ELSE
306 iwa(6)= nglobth
307 ENDIF
308c
309
310 CALL wrtdes(iwa,iwa,6,ittyp,0)
311 j = iwa(6)
312 IF(ALLOCATED(iwa)) DEALLOCATE(iwa)
313 ALLOCATE(iwa(nglobth))
314 DO i=1,j
315 iwa(i)=i
316 ENDDO
317
318 IF(iunit == iuhis) CALL wrtdes(iwa,iwa,nglobth,ittyp,0)
319 nvar = 0
320 DO n=1,npart+nthpart
321 nvar=max(nvar,iparth(nvparth,n))
322 ENDDO
323 IF(ALLOCATED(iwa)) DEALLOCATE(iwa)
324 ALLOCATE(iwa(nvar))
325C-------PART DESCRIPTION------------
326 DO n=1,npart+nthpart
327 nvar=iparth(nvparth,n)
328 iad =iparth(nvparth+1,n)
329 CALL fretitl2(titl,ipart(lipart1-ltitr+1,n),40)
330 DO i=1,ltitl
331 ititle(i)=ichar(titl(i:i))
332 ENDDO
333 IF (n > npart)THEN
334 ipart1 = 0
335 ipart2 = 0
336 ELSE
337 ipart1 = ipart(1,n)
338 ipart2 = ipart(2,n)
339 ENDIF
340 IF(ittyp==0)THEN
341 IF(ltitl==40)THEN
342 READ(titl,'(10A4)')tit40
343 WRITE(iunit)ipart(4,n),tit40,ipart(7,n),
344 . ipart1,ipart2,nvar
345 ELSE IF(ltitl==80)THEN
346 READ(titl,'(20A4)')tit80
347 WRITE(iunit)ipart(4,n),tit80,ipart(7,n),
348 . ipart1,ipart2,nvar
349 ELSE
350 READ(titl,'(25A4)')tit100
351 WRITE(iunit)ipart(4,n),tit100,ipart(7,n),
352 . ipart1,ipart2,nvar
353 ENDIF
354 ELSEIF(ittyp==1)THEN
355 ELSEIF(ittyp==2)THEN
356 WRITE(iunit,'(A,I5,A,I5,A,I5,A)')eor,1,'I',40,'C',4,'I'
357 WRITE(iunit,'(I10,A,4I5)')ipart(4,n),titl(1:ltitl),
358 . ipart(7,n),ipart1,ipart2,nvar
359 ELSEIF(ittyp==3)THEN
360 CALL eor_c(20+ltitl)
361 CALL write_i_c(ipart(4,n),1)
362 CALL write_c_c(ititle,ltitl)
363 CALL write_i_c(ipart(7,n),1)
364 CALL write_i_c(ipart1,1)
365 CALL write_i_c(ipart2,1)
366 CALL write_i_c(nvar,1)
367 CALL eor_c(20+ltitl)
368 ENDIF
369 ii=0
370 DO i=iad,iad+nvar-1
371 ii=ii+1
372 IF(i <= sithbuf) THEN
373 iwa(ii)=ithbuf(i)
374 ELSE
375 iwa(ii) = 0
376 ENDIF
377 ENDDO
378 IF(nvar/=0)CALL wrtdes(iwa,iwa,nvar,ittyp,0)
379 ENDDO
380C-------MATER DESCRIPTION------------
381 DO n=1,nummat
382 mid = ipm(1,n)
383 CALL fretitl2(titl,ipm(npropmi-ltitr+1,n),40)
384 titlsum=sum(ipm(npropmi-ltitr+1:npropmi-ltitr+40,n))
385 IF(titlsum == 0)THEN
386 titl(1:ltitl)=' '
387 titl(1:8)='no_title'
388 ENDIF
389 DO i=1,ltitl
390 ititle(i)=ichar(titl(i:i))
391 ENDDO
392 IF(ittyp==0)THEN
393 IF(ltitl==40)THEN
394 READ(titl,'(10A4)')tit40
395 WRITE(iunit)mid,tit40
396 ELSE IF(ltitl==80)THEN
397 READ(titl,'(20A4)')tit80
398 WRITE(iunit)mid,tit80
399 ELSE
400 READ(titl,'(25A4)')tit100
401 WRITE(iunit)mid,tit100
402 ENDIF
403 ELSEIF(ittyp==1)THEN
404 ELSEIF(ittyp==2)THEN
405 WRITE(iunit,'(A,I5,A,I5,A)')eor,1,'I',ltitl,'C'
406 WRITE(iunit,'(I10,A)')mid,titl(1:ltitl)
407 ELSEIF(ittyp==3)THEN
408 CALL eor_c(4+ltitl)
409 CALL write_i_c(mid,1)
410 CALL write_c_c(ititle,ltitl)
411 CALL eor_c(4+ltitl)
412 ENDIF
413 ENDDO
414C-------GEO DESCRIPTION------------
415 DO n=1,numgeo
416 pid = igeo(1,n)
417 CALL fretitl2(titl,igeo(npropgi-ltitr+1,n),40)
418 DO i=1,ltitl
419 ititle(i)=ichar(titl(i:i))
420 ENDDO
421 IF(ittyp==0)THEN
422 IF(ltitl==40)THEN
423 READ(titl,'(10A4)')tit40
424 WRITE(iunit)pid,tit40
425 ELSE IF(ltitl==80)THEN
426 READ(titl,'(20A4)')tit80
427 WRITE(iunit)pid,tit80
428 ELSE
429 READ(titl,'(25A4)')tit100
430 WRITE(iunit)pid,tit100
431 ENDIF
432 ELSEIF(ittyp==1)THEN
433 ELSEIF(ittyp==2)THEN
434 WRITE(iunit,'(A,I5,A,I5,A)')eor,1,'I',ltitl,'C'
435 WRITE(iunit,'(I10,A)')pid,titl(1:ltitl)
436
437 ELSEIF(ittyp==3)THEN
438 CALL eor_c(4+ltitl)
439 CALL write_i_c(pid,1)
440 CALL write_c_c(ititle,ltitl)
441 CALL eor_c(4+ltitl)
442 ENDIF
443 ENDDO
444C-------HIERARCHY DESCRIPTION------------
445 IF(ALLOCATED(iwa)) DEALLOCATE(iwa)
446 nvar = 0
447 DO n=1,nsubs
448 nvar=max(nvar,subset(n)%NVARTH(ithflag))
449 ENDDO
450 ALLOCATE(iwa(nvar))
451 DO n=1,nsubs
452!! NVAR=ISUBTH(NVSUBTH,N)
453!! IAD =ISUBTH(NVSUBTH+1,N)
454 nvar=subset(n)%NVARTH(ithflag)
455 iad =subset(n)%THIAD
456!! CALL FRETITL2(TITL,ISUBS(LISUB1-LTITR+1,N),40)
457 titl = subset(n)%TITLE
458 DO i=1,ltitl
459 ititle(i)=ichar(titl(i:i))
460 ENDDO
461 IF(ittyp==0)THEN
462 IF(ltitl==40)THEN
463 READ(titl,'(10A4)')tit40
464!! WRITE(IUNIT)ISUBS(1,N),ISUBS(10,N),
465!! . ISUBS(2,N),ISUBS(4,N),NVAR,TIT40
466 WRITE(iunit)subset(n)%ID,subset(n)%PARENT,
467 . subset(n)%NCHILD,subset(n)%NPART,nvar,tit40
468 ELSE IF(ltitl==00)THEN
469 READ(titl,'(20A4)')tit80
470!! WRITE(IUNIT)ISUBS(1,N),ISUBS(10,N),
471!! . ISUBS(2,N),ISUBS(4,N),NVAR,TIT80
472 WRITE(iunit)subset(n)%ID,subset(n)%PARENT,
473 . subset(n)%NCHILD,subset(n)%NPART,nvar,tit80
474 ELSE
475 READ(titl,'(25A4)')tit100
476!! WRITE(IUNIT)ISUBS(1,N),ISUBS(10,N),
477!! . ISUBS(2,N),ISUBS(4,N),NVAR,TIT100
478 WRITE(iunit)subset(n)%ID,subset(n)%PARENT,
479 . subset(n)%NCHILD,subset(n)%NPART,nvar,tit100
480 ENDIF
481 ELSEIF(ittyp==1)THEN
482 ELSEIF(ittyp==2)THEN
483 WRITE(iunit,'(A,I5,A,I5,A)')eor,5,'I',ltitl,'C'
484!! WRITE(IUNIT,'(5I10,A)')ISUBS(1,N),ISUBS(10,N),
485!! . ISUBS(2,N),ISUBS(4,N),NVAR,TITL(1:LTITL)
486 WRITE(iunit,'(5I10,A)')subset(n)%ID,subset(n)%PARENT,
487 . subset(n)%NCHILD,subset(n)%NPART,nvar,titl(1:ltitl)
488 ELSEIF(ittyp==3)THEN
489 CALL eor_c(20+ltitl)
490!! CALL WRITE_I_C(ISUBS(1,N),1)
491 CALL write_i_c(subset(n)%ID,1)
492!! CALL WRITE_I_C(ISUBS(10,N),1)
493 CALL write_i_c(subset(n)%PARENT,1)
494!! CALL WRITE_I_C(ISUBS(2,N),1)
495 CALL write_i_c(subset(n)%NCHILD,1)
496!! CALL WRITE_I_C(ISUBS(4,N),1)
497 CALL write_i_c(subset(n)%NPART,1)
498 CALL write_i_c(nvar,1)
499 CALL write_c_c(ititle,ltitl)
500 CALL eor_c(20+ltitl)
501 ENDIF
502!! IF(ISUBS(2,N)/=0)CALL WRTDES(IBUFSSG(ISUBS(3,N)),
503!! . IBUFSSG(ISUBS(3,N)),ISUBS(2,N),ITTYP,0)
504 IF(subset(n)%NCHILD/=0)CALL wrtdes(subset(n)%CHILD,
505 . subset(n)%CHILD,subset(n)%NCHILD,ittyp,0)
506!! IF(ISUBS(4,N)/=0)CALL WRTDES(IBUFSSG(ISUBS(5,N)),
507!! . IBUFSSG(ISUBS(5,N)),ISUBS(4,N),ITTYP,0)
508 IF(subset(n)%NPART/=0)CALL wrtdes(subset(n)%PART,
509 . subset(n)%PART,subset(n)%NPART,ittyp,0)
510 ii=0
511 DO i=iad,iad+nvar-1
512 ii=ii+1
513 iwa(ii)=ithbuf(i)
514 ENDDO
515 IF(nvar/=0)CALL wrtdes(iwa,iwa,nvar,ittyp,0)
516 ENDDO
517C-------TH GROUP------------
518 DO n=1,nthgrp2
519 nvar=ithgrp(6,n)
520 CALL fretitl2(titl,ithgrp(nithgr-ltitr+1,n),40)
521 DO i=1,ltitl
522 ititle(i)=ichar(titl(i:i))
523 ENDDO
524C (nstrands elements are treated as a spring group)
525 ity=ithgrp(2,n)
526 IF (ity==100) ity=6
527 IF(ittyp==0)THEN
528 IF(ltitl==40)THEN
529 READ(titl,'(10A4)')tit40
530 WRITE(iunit)ithgrp(1,n),ity,
531 . ithgrp(3,n),ithgrp(4,n),ithgrp(6,n),tit40
532 ELSE IF(ltitl==80)THEN
533 READ(titl,'(20A4)')tit80
534 WRITE(iunit)ithgrp(1,n),ity,
535 . ithgrp(3,n),ithgrp(4,n),ithgrp(6,n),tit80
536 ELSE
537 READ(titl,'(25A4)')tit100
538 WRITE(iunit)ithgrp(1,n),ity,
539 . ithgrp(3,n),ithgrp(4,n),ithgrp(6,n),tit100
540 ENDIF
541 ELSEIF(ittyp==1)THEN
542 ELSEIF(ittyp==2)THEN
543 WRITE(iunit,'(A,I5,A,I5,A)')eor,5,'I',ltitl,'C'
544 WRITE(iunit,'(5I10,A)')ithgrp(1,n),ity,
545 . ithgrp(3,n),ithgrp(4,n),ithgrp(6,n),titl(1:ltitl)
546 ELSEIF(ittyp==3)THEN
547 CALL eor_c(20+ltitl)
548 CALL write_i_c(ithgrp(1,n),1)
549 CALL write_i_c(ity,1)
550 CALL write_i_c(ithgrp(3,n),1)
551 CALL write_i_c(ithgrp(4,n),1)
552 CALL write_i_c(ithgrp(6,n),1)
553 CALL write_c_c(ititle,ltitl)
554 CALL eor_c(20+ltitl)
555 ENDIF
556 iad1=ithgrp(5,n)+2*ithgrp(4,n)
557 iad2=ithgrp(8,n)
558 DO j=1,ithgrp(4,n)
559 CALL fretitl2(titl,ithbuf(iad2),40)
560 DO i=1,ltitl
561 ititle(i)=ichar(titl(i:i))
562 ENDDO
563 IF(ittyp==0)THEN
564 IF(ltitl==40)THEN
565 READ(titl,'(10A4)')tit40
566 WRITE(iunit)ithbuf(iad1),tit40
567 ELSE IF(ltitl==80)THEN
568 READ(titl,'(20A4)')tit80
569 WRITE(iunit)ithbuf(iad1),tit80
570 ELSE
571 READ(titl,'(25A4)')tit100
572 WRITE(iunit)ithbuf(iad1),tit100
573 ENDIF
574 ELSEIF(ittyp==1)THEN
575 ELSEIF(ittyp==2)THEN
576 WRITE(iunit,'(A,I5,A,I5,A)')eor,1,'I',ltitl,'C'
577 WRITE(iunit,'(I10,A)')ithbuf(iad1),titl(1:ltitl)
578 ELSEIF(ittyp==3)THEN
579 CALL eor_c(4+ltitl)
580 CALL write_i_c(ithbuf(iad1),1)
581 CALL write_c_c(ititle,ltitl)
582 CALL eor_c(4+ltitl)
583 ENDIF
584 iad1=iad1+1
585 iad2=iad2+40
586 ENDDO
587 IF(nvar/=0)THEN
588 CALL wrtdes(ithbuf(ithgrp(7,n)),
589 . ithbuf(ithgrp(7,n)),nvar,ittyp,0)
590 IF(th_titles == 1)THEN
591 DO i=1,ithgrp(4,n)
592 DO j=1,nvar
593 DO k=1,10
594 var(k:k)=char(ithvar((ithgrp(9,n)-1+j-1)*10+k))
595 ENDDO
596 WRITE(ifiltitl,'(I10)')ithgrp(2,n)
597 WRITE(ifiltitl,'(A)')var(1:10)
598 ENDDO
599 ENDDO
600 ENDIF
601 ENDIF
602 ENDDO
603C-------TH GROUP + 1 section fluide------------
604 IF(ALLOCATED(iwa)) DEALLOCATE(iwa)
605 ALLOCATE(iwa(6))
606 IF(nsect==0.AND.nsflsw/=0) THEN
607 nvar=6
608 titl='FLUID SECTION'
609 IF(ittyp==0)THEN
610 IF(ltitl==40)THEN
611 READ(titl,'(10A4)')tit40
612 WRITE(iunit)104,104,
613 . 1,nsflsw,nvar,tit40
614 ELSE IF(ltitl==80)THEN
615 READ(titl,'(20A4)')tit80
616 WRITE(iunit)104,104,
617 . 1,nsflsw,nvar,tit80
618 ELSE
619 READ(titl,'(25A4)')tit100
620 WRITE(iunit)104,104,
621 . 1,nsflsw,nvar,tit100
622 ENDIF
623 ELSEIF(ittyp==1)THEN
624 ELSEIF(ittyp==2)THEN
625 WRITE(iunit,'(A,I5,A,I5,A)')eor,5,'I',ltitl,'C'
626 WRITE(iunit,'(5I10,A)')104,104,
627 . 1,nsflsw,ithgrp(6,n),titl(1:ltitl)
628 ELSEIF(ittyp==3)THEN
629 DO i=1,ltitl
630 ititle(i)=ichar(titl(i:i))
631 ENDDO
632 CALL eor_c(20+ltitl)
633 CALL write_i_c(104,1)
634 CALL write_i_c(104,1)
635 CALL write_i_c(1,1)
636 CALL write_i_c(nsflsw,1)
637 CALL write_i_c(nvar,1)
638 CALL write_c_c(ititle,ltitl)
639 CALL eor_c(20+ltitl)
640 ENDIF
641 DO j=1,nsflsw
642 IF(ittyp==0)THEN
643 IF(ltitl==40)THEN
644 WRITE(iunit)j,tit40
645 ELSE IF(ltitl==80)THEN
646 WRITE(iunit)j,tit80
647 ELSE
648 WRITE(iunit)j,tit100
649 ENDIF
650 ELSEIF(ittyp==1)THEN
651 ELSEIF(ittyp==2)THEN
652 WRITE(iunit,'(A,I5,A,I5,A)')eor,1,'I',ltitl,'C'
653 WRITE(iunit,'(I10,A)')j,titl(1:ltitl)
654 ELSEIF(ittyp==3)THEN
655 CALL eor_c(4+ltitl)
656 CALL write_i_c(j,1)
657 CALL write_c_c(ititle,ltitl)
658 CALL eor_c(4+ltitl)
659 ENDIF
660 ENDDO
661 DO i=1,6
662 iwa(i)=i
663 ENDDO
664 CALL wrtdes(iwa,iwa,6,ittyp,0)
665 ENDIF
666C
667 IF ((irad2r==1).AND.(r2r_siu==1)) THEN
668 CALL flu_fil_c()
669 IF (iddom==0) THEN
670 seek_loc = iunit-29
671 IF (iunit == 3) seek_loc = 1
672 seek_flag(seek_loc) = 1
673 ENDIF
674 ENDIF
675C
676 IF(th_titles == 1) CLOSE(ifiltitl)
677C
678 DEALLOCATE(iwa)
679 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:662
inoutfile_mod
Definition inoutfile_mod.F:96
inoutfile_mod::outfile_name
character(len=outfile_char_len) outfile_name
Definition inoutfile_mod.F:111
inoutfile_mod::outfile_name_len
integer outfile_name_len
Definition inoutfile_mod.F:109
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::ltitle
integer, parameter ltitle
Definition names_and_titles_mod.F:1007
th_mod
Definition th_mod.F:42
th_mod::th_titles
integer th_titles
Definition th_mod.F:70
nvar
integer function nvar(text)
Definition nvar.F:32
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
stri
character *8 function stri(n)
Definition stri.F:24
strr
character *8 function strr(y)
Definition strr.F:34
names_and_titles_mod::names_and_titles_
Definition names_and_titles_mod.F:1016
my_ctime
void my_ctime(int *p)
Definition timer_c.c:29
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645
flu_fil_c
void flu_fil_c()
Definition write_routtines.c:901
write_r_c
void write_r_c(float *w, int *len)
Definition write_routtines.c:519
eor_c
void eor_c(int *len)
Definition write_routtines.c:498
cur_fil_c
void cur_fil_c(int *nf)
Definition write_routtines.c:477
write_c_c
void write_c_c(int *w, int *len)
Definition write_routtines.c:591
open_c
void open_c(int *ifil, int *len, int *mod)
Definition write_routtines.c:180
wrtdes
subroutine wrtdes(a, ia, l, iform, ir)
Definition wrtdes.F:45