1 files changed, 74 insertions, 0 deletions
diff --git a/dfsynthe/repacktio.for b/dfsynthe/repacktio.for
new file mode 100644
index 0000000..bc2d224
--- /dev/null
+++ b/dfsynthe/repacktio.for
@@ -0,0 +1,74 @@
+      PROGRAM RPACKEDLINES
+      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
+C     TIOLINES
+      OPEN(UNIT=11,TYPE='OLD',FORM='UNFORMATTED',
+     1RECORDTYPE='FIXED',BLOCKSIZE=8000,RECL=4)
+      OPEN(UNIT=12,TYPE='NEW',FORM='UNFORMATTED',
+     1RECORDTYPE='FIXED',BLOCKSIZE=32000,RECL=8000)
+      DO 5 LINE=1,50000000
+      READ(11,END=8)IIIIIII
+      IF(IWL.LT.IWLSTART)GO TO 5
+      IF(IWL.GT.IWLSTOP)GO TO 5
+      KGFLOG=IGFLOG
+      ISO=ABS(IELION)-8949
+      GO TO (811,812,813,814,815),ISO
+C     46TiO
+  811 IGFLOG=MAX(KGFLOG-1101,1)
+      GO TO 816
+C     47TiO
+  812 IGFLOG=MAX(KGFLOG-1138,1)
+      GO TO 816
+C     48TiO
+  813 IGFLOG=MAX(KGFLOG-131,1)
+      GO TO 816
+C     49TiO
+  814 IGFLOG=MAX(KGFLOG-1259,1)
+      GO TO 816
+C     50TiO
+  815 IGFLOG=MAX(KGFLOG-1272,1)
+  816 IELION=366
+      IGS=1
+C     added 27 apr 2009--Evan Kirby
+      IGW=9384
+C
+      WLVAC=EXP(IWL*RATIOLOG)
+      IXWL=DLOG(WLVAC)/RATIOLG+.5D0
+      NBUFF=IXWL-IXWLBEG+1
+      IWL=NBUFF
+      CALL PACK(IIIIIII)
+      NLINES=NLINES+1
+    5 CONTINUE
+    8 PRINT 1,NLINES
+    1 FORMAT(I10,' LINES FROM TIOLINES')
+      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