1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
PROGRAM REPACKH2O
IMPLICIT REAL*8 (A-H,O-Z)
COMMON /PACK8000/PACK8000(4,2000)
INTEGER*2 IELION,IELO,IGFLOG,IGR,IGS,IGW
COMMON /IIIIIII/IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW
INTEGER*4 IIIIIII(4),PACK8000
EQUIVALENCE (IIIIIII(1),IWL)
RATIOLOG=LOG(1.D0+1.D0/2000000.D0)
RATIOLG=LOG(1.D0+1.D0/500000.D0)
WLBEG=8.97666
WLEND=10000.
IXWLBEG=DLOG(WLBEG)/RATIOLG
IF(DEXP(IXWLBEG*RATIOLG).LT.WLBEG)IXWLBEG=IXWLBEG+1
IWLSTART=DLOG(WLBEG)/RATIOLOG+.5
IWLSTOP=DLOG(WLEND)/RATIOLOG+.5
NLINES=0
OPEN(UNIT=11,TYPE='OLD',FORM='UNFORMATTED',
1RECORDTYPE='FIXED',BLOCKSIZE=8000,RECL=2)
OPEN(UNIT=12,TYPE='NEW',FORM='UNFORMATTED',
1RECORDTYPE='FIXED',BLOCKSIZE=32000,RECL=8000)
DO 5 LINE=1,65912356
READ(11)IWL,IELO,IGFLOG
IF(IWL.LT.IWLSTART)GO TO 5
IF(IWL.GT.IWLSTOP)GO TO 5
C ELO=ABS(IELO)
KGFLOG=ABS(IGFLOG)
1871 ISO=1
IF(IELO.GT.0.AND.IGFLOG.GT.0)GO TO 1819
ISO=2
IF(IELO.GT.0)GO TO 1819
ISO=3
IF(IGFLOG.GT.0)GO TO 1819
ISO=4
1819 GO TO (1811,1812,1813,1814),ISO
C 1H1H16O
1811 IGFLOG=MAX(KGFLOG-001,1)
GO TO 1816
C 1H1H17O
1812 IGFLOG=MAX(KGFLOG-3398,1)
GO TO 1816
C 1H1H18O
1813 IGFLOG=MAX(KGFLOG-2690,1)
GO TO 1816
C 1H2H16O
1814 IGFLOG=MAX(KGFLOG-5000,1)
1816 IELION=534
IELO=ABS(IELO)
C GAMMAS=0.
IGS=1
C LOG GAMMAW=-7
IGW=9384
CC il giusto sarebbe 9384 per avere -7. In realta' e' -6.964
WLVAC=EXP(IWL*RATIOLOG)
IXWL=DLOG(WLVAC)/RATIOLG+.5D0
NBUFF=IXWL-IXWLBEG+1
IWL=NBUFF
GAMMAR=2.223E13/WLVAC**2*.001
GR=LOG10(GAMMAR)
IGR=GR*1000.+16384.5
CALL PACK(IIIIIII)
NLINES=NLINES+1
5 CONTINUE
8 PRINT 1,NLINES
1 FORMAT(I10,' LINES FROM H2OFAST')
WRITE(12)PACK8000
CALL EXIT
END
SUBROUTINE PACK(IIIIIII)
INTEGER*4 PACK8000,IIIIIII(4)
COMMON /PACK8000/PACK8000(4,2000)
DATA IREC/0/
IREC=IREC+1
PACK8000(1,IREC)=IIIIIII(1)
PACK8000(2,IREC)=IIIIIII(2)
PACK8000(3,IREC)=IIIIIII(3)
PACK8000(4,IREC)=IIIIIII(4)
IF(IREC.EQ.2000)THEN
WRITE(12)PACK8000
IREC=0
ENDIF
RETURN
END
|
