PROGRAM SUBHIT ! ! VERSION (update VERSID) ! 27NOV18 AD v2.00 F90 conversion. ! ! DESCRIPTION ! Program to subset HITRAN .par file by wavenumber range and/or molecule ! ! COMPILATION ! Single program module, so simply (eg): gfortran subhit.f90 -o subhit ! IMPLICIT NONE ! ! VARIABLE KINDS INTEGER, PARAMETER :: I4 = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: R4 = SELECTED_REAL_KIND(6) INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND(15,200) ! ! LOCAL CONSTANTS INTEGER(I4), PARAMETER :: LUNOLD = 1 ! LUN for HITRAN input file INTEGER(I4), PARAMETER :: LUNNEW = 2 ! LUN for HITRAN subset output file INTEGER(I4), PARAMETER :: MAXISO = 15 ! Max no.of isotopes per molecule INTEGER(I4), PARAMETER :: MAXMOL = 100 ! Max no different molecules REAL(R8), PARAMETER :: WNOBIG = 1.0D6 ! > any expected Wno value ! ! LOCAL VARIABLES LOGICAL :: ANYEXC = .FALSE. ! T=exclude specific molec/isotopes LOGICAL :: LINCLD ! T=read list of mols to inc, F=exclude LOGICAL :: USEMOL(MAXISO,MAXMOL) ! T=use molec,isotop combination LOGICAL :: WARN = .FALSE. ! T=warn if duplicates in inc/exc list INTEGER(I4) :: IDOT ! T='.' in molec/iso list, so add isotope INTEGER(I4) :: IISO ! Isotope# INTEGER(I4) :: ILEN ! Length of next field in incl/excl list INTEGER(I4) :: IMOL ! Molecule# INTEGER(I4) :: INCEXC ! Counter (1:2) for incl(1) or excl(2) INTEGER(I4) :: IOS ! Saved value of IOSTAT INTEGER(I4) :: NEXC ! Counter for number of records excluded INTEGER(I4) :: NREC ! Counter for number of records written REAL(R8) :: WNO ! Current wavenumber [cm-1] REAL(R8) :: WNORQ1 = 0.0D0 ! Min wavenumber [cm-1] for output file REAL(R8) :: WNORQ2 = WNOBIG ! Max wavenumber [cm-1] for output file CHARACTER(200) :: FILNAM ! Name of HITRAN input/output files CHARACTER(200) :: REC200 ! User responses CHARACTER(160) :: REC160 ! HITRAN file record ! ! EXECUTABLE CODE ------------------------------------------------------------- ! WRITE ( *, * ) 'R-SUBHIT: Running SUBHIT v2.00' ! Version ID ! ! Prompt for input file and open WRITE ( *, '(A)', ADVANCE='NO' ) 'Input HITRAN file: ' READ ( *, '(A)' ) FILNAM OPEN ( UNIT=LUNOLD, FILE=FILNAM, STATUS='OLD', ACTION='READ', & ERR=910, IOSTAT=IOS) ! ! Get wavenumber range for output (default = use all) WRITE ( *, '(A)', ADVANCE='NO' ) 'Wavenumber range (cm-1) [=all]: ' READ ( *, '(A)' ) REC200 IF ( REC200 .NE. '' ) THEN READ ( REC200, *, IOSTAT=IOS ) WNORQ1, WNORQ2 IF ( IOS .NE. 0 ) STOP 'F-SUBHIT: error reading wavenumber limits' END IF ! ! Advance file pointer prior to loading first record DO READ ( LUNOLD, '(3X,F12.6)', END=910, ERR=910, IOSTAT=IOS ) WNO IF ( WNO .GE. WNORQ1 ) EXIT END DO BACKSPACE ( LUNOLD, ERR=910, IOSTAT=IOS ) ! ! Prompt user for list of molecules to include/exclude DO INCEXC = 1, 2 LINCLD = INCEXC .EQ. 1 USEMOL = .NOT. LINCLD ! initialise defaults to opposite sense of LINCLD IF ( LINCLD ) THEN WRITE ( *, '(A)', ADVANCE='NO' ) 'List of Molec# to include: ' ELSE WRITE ( *, '(A)', ADVANCE='NO' ) 'List of Molec# to exclude: ' END IF READ ( *, '(A)' ) REC200 IF ( REC200 .EQ. '' ) CYCLE ! DO ILEN = INDEX ( REC200//' ', ' ' ) - 1 ! Length of next field IF ( ILEN .EQ. 0 ) EXIT ! Read to end of record IDOT = INDEX ( REC200(1:ILEN), '.' ) IF ( IDOT .EQ. 0 ) THEN ! Plain molecule index READ ( REC200(1:ILEN), *, IOSTAT=IOS, ERR=930 ) IMOL ELSE READ ( REC200(1:IDOT-1), *, IOSTAT=IOS, ERR=930 ) IMOL READ ( REC200(IDOT+1:ILEN), *, IOSTAT=IOS, ERR=930 ) IISO END IF IF ( IMOL .LE. 0 .OR. IMOL .GT. MAXMOL ) THEN WRITE ( *, * ) 'F-SUBHIT: Molec# outside range 1:', MAXMOL STOP END IF IF ( IDOT .EQ. 0 ) THEN ! No isotope defined WARN = WARN .OR. ANY ( USEMOL(:,IMOL) .EQV. LINCLD ) USEMOL(:,IMOL) = LINCLD ELSE ! Isotope also defined IF ( IISO .LE. 0 .OR. IISO .GT. MAXISO ) THEN WRITE ( *, * ) 'F-SUBHIT: Isotop# outside range 1:', MAXISO STOP END IF WARN = WARN .OR. USEMOL(IISO,IMOL) .EQV. LINCLD USEMOL(IISO,IMOL) = LINCLD ENDIF REC200 = ADJUSTL ( REC200(ILEN+1:) ) ANYEXC = .NOT. LINCLD END DO IF ( WARN ) WRITE ( *, * ) 'W-GETMOL: Repeated Molec/Isotope in user-input' EXIT ! include or exclude but not both END DO ! ! Prompt for output file and open WRITE ( *, '(A)', ADVANCE='NO' ) 'Output HITRAN subset file: ' READ ( *, '(A)' ) FILNAM OPEN ( UNIT=LUNNEW, FILE=FILNAM, STATUS='UNKNOWN', ACTION='WRITE', & ERR=920, IOSTAT=IOS ) ! NEXC = 0 NREC = 0 DO READ ( LUNOLD, '(A)', END=100, ERR=910, IOSTAT=IOS ) REC160 READ ( REC160(4:15), '(F12.6)' ) WNO IF ( WNO .GT. WNORQ2 ) EXIT READ ( REC160(1:2), '(I2)' ) IMOL READ ( REC160(3:3), '(Z1)' ) IISO ! HITRAN uses Isotope Id '0','A','B' to represent #10,11,12, so adjust SELECT CASE ( IISO ) CASE ( 0 ) ; IISO = 10 CASE ( 10:15 ) ; IISO = IISO + 1 CASE DEFAULT ; END SELECT IF ( IISO .LE. 0 .OR. IISO .GT. MAXISO ) THEN WRITE ( *, '(A,A15,A,I2,A,I2)' ) 'F-SUBHIT: Record starting:', & REC160(1:15), ' has isotope#', IISO, ' outside range 0:', MAXISO STOP END IF IF ( IMOL .LE. 0 .OR. IMOL .GT. MAXMOL ) THEN WRITE ( *, '(A,A15,A,I2,A,I3)' ) 'F-SUBHIT: Record starting:', & REC160(1:15), ' has molec#', IMOL, ' outside range 1:', MAXMOL STOP END IF IF ( USEMOL(IISO,IMOL) ) THEN WRITE ( LUNNEW, '(A)', IOSTAT=IOS, ERR=920 ) REC160 NREC = NREC + 1 IF ( MOD ( NREC, 100000 ) .EQ. 0 ) WRITE ( *, '(A,I8,A,F12.6)' ) & 'I-SUBHIT: Record#', NREC, ' Wavenumber=', WNO ELSE NEXC = NEXC + 1 END IF END DO 100 CONTINUE ! IF ( NREC .EQ. 0 ) THEN STOP 'F-SUBHIT: no records found matching subset criteria' ELSE WRITE ( *, * ) 'I-SUBHIT: Number of records written =', NREC IF ( ANYEXC ) THEN IF ( NEXC .EQ. 0 ) THEN WRITE ( *, * ) 'W-SUBHIT: no records excluded' ELSE WRITE ( *, * ) 'I-SUBHIT: Number of records excluded=', NEXC END IF END IF STOP 'R-SUBHIT: Successful completion' END IF ! ! Various Fatal I/O Error terminations 910 CONTINUE WRITE ( *, * ) 'F-SUBHIT: I/O Error on input file. IOSTAT=', IOS STOP ! 920 CONTINUE WRITE ( *, * ) 'F-SUBHIT: I/O Error on output file. IOSTAT=', IOS STOP ! 930 CONTINUE WRITE ( *, * ) 'F-SUBHIT: I/O Error reading list of molec#. IOSTAT=', IOS ! END PROGRAM SUBHIT