PROGRAM TABHDR ! ! VERSION (update VERSID) ! 16DEC19 AD v2.0: Convert from F77 to F90 ! 05AUG15 AD v1.31 Change '$' in WRITE statements to avoid gfortran warnings ! 16APR15 AD v1.3: correction: add local function MOLIDX ! 24FEB15 AD v1.2: modified OPNTAB to improve detection of file-type ! 17DEC14 AD v1.1: modified RWAXIS to allow for format identifier ! 05NOV14 AD Original. ! ! DESCRIPTION ! Program to extract Header info from .tab files ! USE TABAUX ! General modules for manipulating RFM .tab files ! IMPLICIT NONE ! ! GLOBAL CONSTANTS CHARACTER(7), PARAMETER :: VERSID = '2.0' ! Program version identifier INTEGER(I4), PARAMETER :: LUNTAB = 1 ! LUN for reading .tab file INTEGER(I4), PARAMETER :: LUNOUT = 2 ! LUN for new .tab file ! ! LOCAL CONSTANTS CHARACTER(*), PARAMETER :: ATMFIL = 'tab.atm' ! File for embedded profiles CHARACTER(*), PARAMETER :: GRDFIL = 'tab.grd' ! File for irreg.grid CHARACTER(*), PARAMETER :: PREFIL = 'tab.pre' ! File for p-axis values CHARACTER(*), PARAMETER :: TEMFIL = 'tab.tem' ! File for T-axis values CHARACTER(*), PARAMETER :: VMRFIL = 'tab.vmr' ! File for q-axis values ! ! LOCAL VARIABLES LOGICAL :: BINTAB ! T=binary .tab file, F=ASCII INTEGER(I4) :: IOS ! Saved value of IOSTAT for error messages INTEGER(I4) :: IV ! Counter for spectral grid points INTEGER(I4) :: IX ! Counter for tabulated values REAL(R4) :: RDUM ! Dummy real number (for reading past k-data) CHARACTER(7) :: GASSTR ! Molecule(isotope) CHARACTER(80) :: PROGID ! Output record containing program identification CHARACTER(6) :: UNITS ! Either '[ppmv]' or, for aerosol, '[km-1]' TYPE(TABTYP) :: TAB ! .tab file header structure REAL(R8), ALLOCATABLE :: VTAB(:) ! Wavenumber grid [cm-1] from .tab file ! ! EXECUTABLE CODE ------------------------------------------------------------- ! WRITE ( *, '(A)' ) 'R-TABHDR: Running TABHDR v' // VERSID ! PROGID = '! Created by program tabhdr.f90 v' // VERSID ! ! Open LUT file and read in contents CALL OPNTAB ( .TRUE., LUNTAB, BINTAB ) CALL RWAXIS ( .TRUE., LUNTAB, BINTAB, TAB ) ! ! Convert numerical code to molecule/isotope name GASSTR = NAMMOL ( TAB%MOL ) ! 12345612345678901234567890 WRITE ( *, '(A,A,2X,A)' ) 'MolecID: ', TAB%MOL, GASSTR WRITE ( *, '(A)' ) 'Summary: NPts <---- Range ---->' WRITE ( *, '(A,I6,1P2G10.3)' ) ' p-axis:', TAB%NP, TAB%PAX(1), TAB%PAX(TAB%NP) WRITE ( *, '(A,I6,1P2G10.3)' ) ' T-axis:', TAB%NT, TAB%TAX(1), TAB%TAX(TAB%NT) WRITE ( *, '(A,I6,1P2G10.3)' ) ' q-axis:', TAB%NQ, TAB%QAX(1), TAB%QAX(TAB%NQ) WRITE ( *, '(A,I6,2F10.4)' ) ' v-axis:', TAB%NV, TAB%V1, TAB%V2 ! WRITE ( *, '(A)' ) 'Writing p-axis values to file: ' // PREFIL OPEN ( LUNOUT, FILE=PREFIL, STATUS='UNKNOWN', ACTION='WRITE', & IOSTAT=IOS, ERR=900) WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '! p-axis values from .tab file.' WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) PROGID WRITE ( LUNOUT, '(8ES10.3)', IOSTAT=IOS, ERR=900 ) TAB%PAX CLOSE ( LUNOUT, IOSTAT=IOS, ERR=900 ) ! WRITE ( *, '(A)' ) 'Writing T-axis values to file: ' // TEMFIL OPEN ( LUNOUT, FILE=TEMFIL, STATUS='UNKNOWN', ACTION='WRITE', & IOSTAT=IOS, ERR=900) WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '! T-axis values from .tab file.' WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) PROGID WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%TAX CLOSE ( LUNOUT, IOSTAT=IOS, ERR=900 ) ! ! Only write out q-axis values if more than one value IF ( TAB%NQ .GT. 1 ) THEN WRITE ( *, '(A)' ) 'Writing q-axis values to file: ' // VMRFIL OPEN ( LUNOUT, FILE=VMRFIL, STATUS='UNKNOWN', ACTION='WRITE', & IOSTAT=IOS, ERR=900 ) WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 )'! q-axis values from .tab file' WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) PROGID WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%QAX CLOSE ( LUNOUT, IOSTAT=IOS, ERR=900 ) END IF ! WRITE ( *, '(A)' ) 'Writing profile values to file: ' // ATMFIL OPEN ( LUNOUT, FILE=ATMFIL, STATUS='UNKNOWN', IOSTAT=IOS, ERR=900) WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) PROGID WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%NP, ' = No. of profile levels' WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '*PRE [hPa]' WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%PAX WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '*TEM [K]' WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%TEM ! IF ( GASSTR .EQ. 'aerosol' ) THEN UNITS = '[km-1]' ELSE UNITS = '[ppmv]' END IF WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '*' // GASSTR // ' ' // UNITS WRITE ( LUNOUT, *, IOSTAT=IOS, ERR=900 ) TAB%VMR WRITE ( LUNOUT, '(A)', IOSTAT=IOS, ERR=900 ) '*END' CLOSE ( LUNOUT, IOSTAT=IOS, ERR=900 ) ! ! If irregular spectral grid, write out .grd file IF ( NINT ( ( TAB%V2 - TAB%V1 ) / TAB%DV ) + 1 .NE. TAB%NV ) THEN WRITE ( *, '(A)' ) 'Writing irregular spectral grid to file: ' // GRDFIL ALLOCATE ( VTAB(TAB%NV) ) IF ( BINTAB ) THEN DO IV = 1, TAB%NV READ ( LUNTAB, IOSTAT=IOS, ERR=900 ) VTAB(IV), ( RDUM, IX = 1, TAB%NX ) END DO ELSE DO IV = 1, TAB%NV READ ( LUNTAB, *, IOSTAT=IOS, ERR=900 ) VTAB(IV), ( RDUM,IX = 1,TAB%NX ) END DO END IF CALL WRTGRD ( LUNOUT, GRDFIL, PROGID, TAB%DV, VTAB, (TAB%NV .LT. 0) ) END IF ! 900 CONTINUE IF ( IOS .EQ. 0 ) THEN WRITE ( *, '(A)' ) 'R-TABHDR: Succesful completion' ELSE WRITE ( *, * ) 'F-TABHDR: I/O error, IOSTAT=', IOS END IF ! END PROGRAM TABHDR