OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hist13.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!|| hist13 ../engine/source/output/th/hist13.F
25!||--- called by ------------------------------------------------------
26!|| radioss2 ../engine/source/engine/radioss2.F
27!||--- calls -----------------------------------------------------
28!|| cur_fil_c ../common_source/tools/input_output/write_routines.c
29!|| eor_c ../common_source/tools/input_output/write_routines.c
30!|| open_c ../common_source/tools/input_output/write_routines.c
31!|| write_c_c ../common_source/tools/input_output/write_routines.c
32!|| write_i_c ../common_source/tools/input_output/write_routines.c
33!|| wrtdes ../engine/source/output/th/wrtdes.F
34!||--- uses -----------------------------------------------------
35!|| element_mod ../common_source/modules/elements/element_mod.F90
36!|| inoutfile_mod ../common_source/modules/inoutfile_mod.F
37!|| names_and_titles_mod ../common_source/modules/names_and_titles_mod.F
38!||====================================================================
39 SUBROUTINE hist13(IPARG ,IXS ,IXQ ,IXC ,IXT ,
40 2 IXP ,IXR ,ITAB ,PM ,
41 3 NPBY ,IXTG ,IRFE ,LACCELM,
42 4 IPARI ,IPART,ITHGRP ,ITHBUF,CHRUN_OLD,NAMES_AND_TITLES)
43C=======================================================================
44C OLD TH V3 RADIOSS INPUT V3 or V4
45C=======================================================================
46 USE inoutfile_mod
47 USE names_and_titles_mod,only:names_and_titles_,ltitle
48 use element_mod , only : nixs,nixq,nixc,nixp,nixr,nixt,nixtg
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com04_c.inc"
57#include "com10_c.inc"
58#include "units_c.inc"
59#include "param_c.inc"
60#include "scr05_c.inc"
61#include "scr12_c.inc"
62#include "scr13_c.inc"
63#include "scr17_c.inc"
64#include "scrfs_c.inc"
65#include "chara_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER IRFE
70 INTEGER IPARG(NPARG,*), IXS(NIXS,*), IXQ(NIXQ,*),
71 . IXC(NIXC,*), IXT(NIXT,*), IXP(NIXP,*), IXR(NIXR,*),
72 . ixtg(nixtg,*),itab(*),
73 . ipari(npari,*),laccelm(3,*),ipart(lipart1,*), npby(nnpby,*),
74 . ithgrp(nithgr,*), ithbuf(*)
75
76 my_real pm(npropm,nummat)
77 CHARACTER CHRUN_OLD*2
78 TYPE(NAMES_AND_TITLES_),INTENT(IN) :: NAMES_AND_TITLES !< NAMES_AND_TITLES host the input deck names and titles for outputs+
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER ITITLE(80), IFILNAM(2148), ICODE, I, NJOINV, NRBAGV,
83 . II, N, MTN, NACCELV,NINTERS,
84 . NN,IAD,J,ITYP
85
86 CHARACTER EOR*8, CH8*8, FILNAM*100, BLA*7
87 CHARACTER(LEN=LTITLE) :: CARD
88 my_real,DIMENSION(20) :: TITLE
89 INTEGER :: LEN_TMP_NAME
90 CHARACTER(len=2148) :: TMP_NAME
91
92 INTEGER NGLV, NMTV, NINV, NRWV, NRBV, NNODV, NSCV, NELQV, NELSV, NELCV, NELTV, NELPV, NELRV, NELTGV, NELURV
93 INTEGER, dimension(:), allocatable :: IWA
94C-----------------------------------------------
95C E x t e r n a l F u n c t i o n s
96C-----------------------------------------------
97 CHARACTER STRI*8
98C-----------------------------------------------
99 EXTERNAL STRI
100 DATA bla/' '/
101 DATA eor/'ZZZZZEOR'/
102C-----------------------------------------------
103C S o u r c e L i n e s
104C-----------------------------------------------
105 ninters = 0
106 DO n=1,nthgrp
107 ityp=ithgrp(2,n)
108 nn =ithgrp(4,n)
109 IF(ityp==101)ninters = ninters + nn
110 ENDDO
111C
112 filnam=rootnam(1:rootlen)//'T'//chrun_old
113C
114 card(1:ltitle)=names_and_titles%TITLE(1:ltitle)
115C ICODE=3017
116C ICODE=3023
117 icode=3030
118C ICODE=3040
119C
120 len_tmp_name = outfile_name_len + rootlen+3
121 tmp_name=outfile_name(1:outfile_name_len)//filnam(1:rootlen+3)
122
123 IF(itform==0)THEN
124 OPEN(unit=iuhis,file=tmp_name(1:len_tmp_name),
125 . access='SEQUENTIAL',
126 . form='UNFORMATTED',status='UNKNOWN')
127 ELSEIF(itform==1.OR.itform==2)THEN
128 OPEN(unit=iuhis,file=tmp_name(1:len_tmp_name),
129 . access='SEQUENTIAL',
130 . form='FORMATTED',status='UNKNOWN')
131 ELSEIF(itform==3)THEN
132 DO i=1,len_tmp_name
133 ifilnam(i)=ichar(tmp_name(i:i))
134 ENDDO
135 CALL cur_fil_c(1)
136 CALL open_c(ifilnam,len_tmp_name,0)
137 ELSEIF(itform==4)THEN
138 DO i=1,len_tmp_name
139 ifilnam(i)=ichar(tmp_name(i:i))
140 ENDDO
141 CALL cur_fil_c(1)
142 CALL open_c(ifilnam,len_tmp_name,3)
143 itform=3
144 ELSEIF(itform==5)THEN
145 DO i=1,len_tmp_name
146 ifilnam(i)=ichar(tmp_name(i:i))
147 ENDDO
148 CALL cur_fil_c(1)
149 CALL open_c(ifilnam,len_tmp_name,6)
150 itform=3
151 ENDIF
152C
153 IF(itform==0)THEN
154 READ(card,'(20A4)')title
155 WRITE(iuhis)icode,title
156 ELSEIF(itform==1)THEN
157 ch8=stri(icode)
158 WRITE(iuhis,'(A)')filnam(1:rootlen+3)
159 WRITE(iuhis,'(2a)')CH8,CARD(1:72)
160 ELSEIF(ITFORM==2)THEN
161 WRITE(IUHIS,'(2a)')FILNAM(1:ROOTLEN+3),' format'
162 WRITE(IUHIS,'(a,i5,a,i5,a)')EOR,1,'i',72,'c'
163 WRITE(IUHIS,'(i5,a)')ICODE,CARD(1:72)
164 ELSEIF(ITFORM==3)THEN
165 DO 5 I=1,80
166 5 ITITLE(I)=ICHAR(CARD(I:I))
167 CALL EOR_C(84)
168 CALL WRITE_I_C(ICODE,1)
169 CALL WRITE_C_C(ITITLE,80)
170 CALL EOR_C(84)
171 ENDIF
172C
173.AND. IF(NSMAT/=0INVSTR<40) THEN
174C 009 DO N=1,NPART
175 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
176 ALLOCATE(IWA(NUMMAT))
177 DO N=1,NUMMAT-1
178 IWA(N)=0
179 ENDDO
180 DO N=1,NPART
181 IF(IPART(8,N)>=1) IWA(IPART(1,N))=1
182 ENDDO
183 NSMAT=0
184 DO N=1,NUMMAT-1
185 NSMAT=NSMAT+IWA(N)
186 ENDDO
187 ENDIF
188C
189 NGLV=12
190 NMTV=6
191 NINV=6
192 NRWV=6
193 NRBV=9
194 NNODV=9
195 NSCV=9
196 NJOINV=6
197 NRBAGV=9
198C NELV=22
199 NACCELV=3
200 NELSV=19
201 NELTV=6
202 NELPV=9
203 NELRV=14
204 NELCV=22
205 NELQV =NELSV
206 NELTGV=NELCV
207 NELURV=12
208C
209C
210 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
211 ALLOCATE(IWA(35))
212 IWA(1) =NGLV
213 IWA(2) =NSMAT
214 IWA(3) =NMTV
215 IWA(4) =NSNOD
216 IWA(5) =NNODV
217 IWA(6) =NSELQ
218 IWA(7) =NELQV
219 IWA(8) =NSELS
220 IWA(9) =NELSV
221 IWA(10)=NSELC
222 IWA(11)=NELCV
223 IWA(12)=NSELT
224 IWA(13)=NELTV
225 IWA(14)=NSELP
226 IWA(15)=NELPV
227 IWA(16)=NSELR
228 IWA(17)=NELRV
229 IWA(18)=NINTERS
230 IWA(19)=NINV
231 IWA(20)=NRWALL
232 IWA(21)=NRWV
233 IWA(22)=NSRBY
234 IWA(23)=NRBV
235 IWA(24)=NSECT
236 IF (NSECT ==0 ) IWA(24)=NSFLSW
237 IWA(25)=NSCV
238 IWA(26)=NJOINT
239 IWA(27)=NJOINV
240 IWA(28)=NRBAG+NVOLU
241 IWA(29)=NRBAGV
242 IWA(30)=NSELTG
243 IWA(31)=NELTGV
244 IWA(32)=NSELU
245 IWA(33)=NELURV
246 IWA(34)=NACCELM
247 IWA(35)=NACCELV
248 IUNIT=IUHIS
249 CALL WRTDES(IWA,IWA,35,ITFORM,0)
250 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
251 ALLOCATE(IWA(2*NUMMAT + NPART))
252 IF(NSMAT/=0) THEN
253 IF(INVSTR<40) THEN
254C 009 DO N=1,NPART
255 DO N=1,NUMMAT-1
256 IWA(N)=0
257 ENDDO
258 II=0
259 DO N=1,NPART
260 IF(IPART(8,N)>=1)THEN
261 II=IPART(1,N)
262 IWA(II)=IPART(5,N)
263 ENDIF
264 ENDDO
265 NSMAT=0
266C 009 DO N=1,NPART
267 DO N=1,NUMMAT-1
268 IF(IWA(N)/=0)THEN
269 NSMAT=NSMAT+1
270 IWA(NSMAT)=IWA(N)
271 ENDIF
272 ENDDO
273 ELSE
274 DO N=1,NPART
275 IWA(N)=IPART(4,N)
276 ENDDO
277 ENDIF
278 ENDIF
279C
280 IF(NSMAT/=0) THEN
281 CALL WRTDES(IWA,IWA,NSMAT,ITFORM,0)
282 ENDIF
283C--------------------------------
284 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
285 IF(NINTERS/=0) THEN
286 ALLOCATE(IWA(NINTERS))
287 II=0
288 DO N=1,NTHGRP
289 ITYP=ITHGRP(2,N)
290 NN =ITHGRP(4,N)
291 IAD =ITHGRP(5,N)
292 IF(ITYP==101)THEN
293 DO J=IAD,IAD+NN-1
294 I=ITHBUF(J)
295 II=II+1
296 IWA(II)=IPARI(15,I)
297 ENDDO
298 ENDIF
299 ENDDO
300 CALL WRTDES(IWA,IWA,NINTERS,ITFORM,0)
301 ENDIF
302C
303 IF(NRWALL /= 0) THEN
304 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
305 ALLOCATE(IWA(NRWALL))
306 II=0
307 DO I=1,NRWALL
308 II=II+1
309 IWA(II)=II
310 ENDDO
311 CALL WRTDES(IWA,IWA,NRWALL,ITFORM,0)
312 DEALLOCATE(IWA)
313 ENDIF
314C
315C--------------------------------
316 IF(NSRBY/=0) THEN
317 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
318 ALLOCATE(IWA(NSRBY))
319 II=0
320 DO N=1,NTHGRP
321 ITYP=ITHGRP(2,N)
322 NN =ITHGRP(4,N)
323 IAD =ITHGRP(5,N)
324 IF(ITYP==103)THEN
325 DO J=IAD,IAD+NN-1
326 I=ITHBUF(J)
327 II=II+1
328 IWA(II)=ITAB(NPBY(1,I))
329c IWA(II)=ITHBUF(J)
330 ENDDO
331 ENDIF
332 ENDDO
333 CALL WRTDES(IWA,IWA,NSRBY,ITFORM,0)
334 ENDIF
335C--------------------------------
336C
337 IF(NSECT/=0) THEN
338 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
339 ALLOCATE(IWA(NSECT))
340 II=0
341 DO I=1,NSECT
342 II=II+1
343 IWA(II)=II
344 ENDDO
345 CALL WRTDES(IWA,IWA,NSECT,ITFORM,0)
346 ELSEIF(NSFLSW/=0) THEN
347 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
348 ALLOCATE(IWA(NSFLSW))
349 II=0
350 DO I=1,NSFLSW
351 II=II+1
352 IWA(II)=II
353 ENDDO
354 CALL WRTDES(IWA,IWA,NSFLSW,ITFORM,0)
355 ENDIF
356C
357 IF(NJOINT/=0) THEN
358 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
359 ALLOCATE(IWA(NJOINT))
360 II=0
361 DO I=1,NJOINT
362 II=II+1
363 IWA(II)=II
364 ENDDO
365 CALL WRTDES(IWA,IWA,NJOINT,ITFORM,0)
366 ENDIF
367C
368 IF(NRBAG+NVOLU/=0) THEN
369 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
370 ALLOCATE(IWA(NRBAG+NVOLU))
371 II=0
372 DO I=1,NRBAG+NVOLU
373 II=II+1
374 IWA(II)=II
375 ENDDO
376 CALL WRTDES(IWA,IWA,NRBAG+NVOLU,ITFORM,0)
377 ENDIF
378C
379C--------------------------------
380 IF(NACCELM/=0) THEN
381 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
382 ALLOCATE(IWA(NACCELM))
383 DO N=1,NACCELM
384 IWA(N)=LACCELM(2,N)
385 ENDDO
386 CALL WRTDES(IWA,IWA,NACCELM,ITFORM,0)
387 ENDIF
388C
389 IF(NSNOD/=0) THEN
390 II=0
391 DO N=1,NTHGRP
392 ITYP=ITHGRP(2,N)
393 NN =ITHGRP(4,N)
394 IAD =ITHGRP(5,N)
395 IF(ITYP==0)THEN
396 DO J=IAD,IAD+NN-1
397 I=ITHBUF(J)
398 II=II+1
399c IWA(II)=ITAB(I)
400 ENDDO
401 ENDIF
402 ENDDO
403 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
404 ALLOCATE(IWA(II))
405 II=0
406 DO N=1,NTHGRP
407 ITYP=ITHGRP(2,N)
408 NN =ITHGRP(4,N)
409 IAD =ITHGRP(5,N)
410 IF(ITYP==0)THEN
411 DO J=IAD,IAD+NN-1
412 I=ITHBUF(J)
413 II=II+1
414 IWA(II)=ITAB(I)
415 ENDDO
416 ENDIF
417 ENDDO
418
419 CALL WRTDES(IWA,IWA,II,ITFORM,0)
420 ENDIF
421C
422 IF (NSELS>0) THEN
423 II=0
424 DO N=1,NTHGRP
425 ITYP=ITHGRP(2,N)
426 NN =ITHGRP(4,N)
427 IAD =ITHGRP(5,N)
428 IF(ITYP==1)THEN
429 DO J=IAD,IAD+NN-1
430 I=ITHBUF(J)
431 MTN=NINT(PM(19,IXS(1,I)))
432 II=II+1
433 II=II+1
434 ENDDO
435 ENDIF
436 ENDDO
437 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
438 ALLOCATE(IWA(II))
439 II=0
440 DO N=1,NTHGRP
441 ITYP=ITHGRP(2,N)
442 NN =ITHGRP(4,N)
443 IAD =ITHGRP(5,N)
444 IF(ITYP==1)THEN
445 DO J=IAD,IAD+NN-1
446 I=ITHBUF(J)
447 MTN=NINT(PM(19,IXS(1,I)))
448 II=II+1
449 IWA(II)=IXS(NIXS,I)
450 II=II+1
451 IWA(II)=MTN
452 ENDDO
453 ENDIF
454 ENDDO
455 CALL WRTDES(IWA,IWA,II,ITFORM,0)
456 ENDIF
457C
458 IF (NSELQ>0) THEN
459 II=0
460 DO N=1,NTHGRP
461 ITYP=ITHGRP(2,N)
462 NN =ITHGRP(4,N)
463 IAD =ITHGRP(5,N)
464 IF(ITYP==2)THEN
465 DO J=IAD,IAD+NN-1
466 I=ITHBUF(J)
467 MTN=NINT(PM(19,IXQ(1,I)))
468 II=II+1
469 IWA(II)=IXQ(NIXQ,I)
470 II=II+1
471 IWA(II)=MTN
472 ENDDO
473 ENDIF
474 ENDDO
475 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
476 ALLOCATE(IWA(II))
477 II=0
478 DO N=1,NTHGRP
479 ITYP=ITHGRP(2,N)
480 NN =ITHGRP(4,N)
481 IAD =ITHGRP(5,N)
482 IF(ITYP==2)THEN
483 DO J=IAD,IAD+NN-1
484 I=ITHBUF(J)
485 MTN=NINT(PM(19,IXQ(1,I)))
486 II=II+1
487 IWA(II)=IXQ(NIXQ,I)
488 II=II+1
489 IWA(II)=MTN
490 ENDDO
491 ENDIF
492 ENDDO
493
494 CALL WRTDES(IWA,IWA,II,ITFORM,0)
495 ENDIF
496C
497 IF (NSELC>0) THEN
498 II=0
499 DO N=1,NTHGRP
500 ITYP=ITHGRP(2,N)
501 NN =ITHGRP(4,N)
502 IAD =ITHGRP(5,N)
503 IF(ITYP==3)THEN
504 DO J=IAD,IAD+NN-1
505 I=ITHBUF(J)
506 MTN=NINT(PM(19,IXC(1,I)))
507 II=II+1
508 II=II+1
509 ENDDO
510 ENDIF
511 ENDDO
512 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
513 ALLOCATE(IWA(II))
514 II=0
515 DO N=1,NTHGRP
516 ITYP=ITHGRP(2,N)
517 NN =ITHGRP(4,N)
518 IAD =ITHGRP(5,N)
519 IF(ITYP==3)THEN
520 DO J=IAD,IAD+NN-1
521 I=ITHBUF(J)
522 MTN=NINT(PM(19,IXC(1,I)))
523 II=II+1
524 IWA(II)=IXC(NIXC,I)
525 II=II+1
526 IWA(II)=MTN
527 ENDDO
528 ENDIF
529 ENDDO
530 CALL WRTDES(IWA,IWA,II,ITFORM,0)
531 ENDIF
532C
533 IF (NSELTG>0) THEN
534 II=0
535 DO N=1,NTHGRP
536 ITYP=ITHGRP(2,N)
537 NN =ITHGRP(4,N)
538 IAD =ITHGRP(5,N)
539 IF(ITYP==7)THEN
540 DO J=IAD,IAD+NN-1
541 I=ITHBUF(J)
542 MTN=NINT(PM(19,IXTG(1,I)))
543 II=II+1
544 IWA(II)=IXTG(NIXTG,I)
545 II=II+1
546 IWA(II)=MTN
547 ENDDO
548 ENDIF
549 ENDDO
550 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
551 ALLOCATE(IWA(II))
552 II=0
553 DO N=1,NTHGRP
554 ITYP=ITHGRP(2,N)
555 NN =ITHGRP(4,N)
556 IAD =ITHGRP(5,N)
557 IF(ITYP==7)THEN
558 DO J=IAD,IAD+NN-1
559 I=ITHBUF(J)
560 MTN=NINT(PM(19,IXTG(1,I)))
561 II=II+1
562 IWA(II)=IXTG(NIXTG,I)
563 II=II+1
564 IWA(II)=MTN
565 ENDDO
566 ENDIF
567 ENDDO
568
569 CALL WRTDES(IWA,IWA,II,ITFORM,0)
570 ENDIF
571C
572 IF (NSELT>0) THEN
573 II=0
574 DO N=1,NTHGRP
575 ITYP=ITHGRP(2,N)
576 NN =ITHGRP(4,N)
577 IAD =ITHGRP(5,N)
578 IF(ITYP==4)THEN
579 DO J=IAD,IAD+NN-1
580 I=ITHBUF(J)
581 MTN=NINT(PM(19,IXT(1,I)))
582 II=II+1
583 II=II+1
584 ENDDO
585 ENDIF
586 ENDDO
587 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
588 ALLOCATE(IWA(II))
589 II=0
590 DO N=1,NTHGRP
591 ITYP=ITHGRP(2,N)
592 NN =ITHGRP(4,N)
593 IAD =ITHGRP(5,N)
594 IF(ITYP==4)THEN
595 DO J=IAD,IAD+NN-1
596 I=ITHBUF(J)
597 MTN=NINT(PM(19,IXT(1,I)))
598 II=II+1
599 IWA(II)=IXT(NIXT,I)
600 II=II+1
601 IWA(II)=MTN
602 ENDDO
603 ENDIF
604 ENDDO
605 CALL WRTDES(IWA,IWA,II,ITFORM,0)
606 ENDIF
607C
608 IF (NSELP>0) THEN
609 II=0
610 DO N=1,NTHGRP
611 ITYP=ITHGRP(2,N)
612 NN =ITHGRP(4,N)
613 IAD =ITHGRP(5,N)
614 IF(ITYP==5)THEN
615 DO J=IAD,IAD+NN-1
616 I=ITHBUF(J)
617 MTN=NINT(PM(19,IXP(1,I)))
618 II=II+1
619 II=II+1
620 ENDDO
621 ENDIF
622 ENDDO
623 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
624 ALLOCATE(IWA(II))
625 II=0
626 DO N=1,NTHGRP
627 ITYP=ITHGRP(2,N)
628 NN =ITHGRP(4,N)
629 IAD =ITHGRP(5,N)
630 IF(ITYP==5)THEN
631 DO J=IAD,IAD+NN-1
632 I=ITHBUF(J)
633 MTN=NINT(PM(19,IXP(1,I)))
634 II=II+1
635 IWA(II)=IXP(NIXP,I)
636 II=II+1
637 IWA(II)=MTN
638 ENDDO
639 ENDIF
640 ENDDO
641
642 CALL WRTDES(IWA,IWA,II,ITFORM,0)
643 ENDIF
644C
645 IF (NSELR>0) THEN
646 II=0
647 DO N=1,NTHGRP
648 ITYP=ITHGRP(2,N)
649 NN =ITHGRP(4,N)
650 IAD =ITHGRP(5,N)
651 IF(ITYP==6)THEN
652 DO J=IAD,IAD+NN-1
653 I=ITHBUF(J)
654 II=II+1
655 II=II+1
656 ENDDO
657 ELSEIF(ITYP==100) THEN
658 DO J=IAD,IAD+NN-1
659 I=ITHBUF(J)
660 II=II+1
661 II=II+1
662 ENDDO
663 ENDIF
664 ENDDO
665 IF(ALLOCATED(IWA)) DEALLOCATE(IWA)
666 ALLOCATE(IWA(II))
667 II=0
668 DO N=1,NTHGRP
669 ITYP=ITHGRP(2,N)
670 NN =ITHGRP(4,N)
671 IAD =ITHGRP(5,N)
672 IF(ITYP==6)THEN
673 DO J=IAD,IAD+NN-1
674 I=ITHBUF(J)
675 II=II+1
676 IWA(II)=IXR(NIXR,I)
677 II=II+1
678 IWA(II)=0
679 ENDDO
680 ELSEIF(ITYP==100) THEN
681 DO J=IAD,IAD+NN-1
682 I=ITHBUF(J)
683 II=II+1
684 IWA(II)=ITHBUF(J+2*NN)
685 II=II+1
686 IWA(II)=0
687 ENDDO
688 ENDIF
689 ENDDO
690 CALL WRTDES(IWA,IWA,II,ITFORM,0)
691 ENDIF
692C
693 RETURN
694 END
my_real
#define my_real
Definition cppsort.cpp:32
hist13
subroutine hist13(iparg, ixs, ixq, ixc, ixt, ixp, ixr, itab, pm, npby, ixtg, irfe, laccelm, ipari, ipart, ithgrp, ithbuf, chrun_old, names_and_titles)
Definition hist13.F:43
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:1002
names_and_titles_mod::ltitle
integer, parameter ltitle
Definition names_and_titles_mod.F:1012
names_and_titles_mod::names_and_titles_
Definition names_and_titles_mod.F:1021
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645
cur_fil_c
void cur_fil_c(int *nf)
Definition write_routines.c:477
open_c
void open_c(int *ifil, int *len, int *mod)
Definition write_routines.c:180