! F90 program MRGGRD ! ! VERSION (update VERSID) ! 11JUN19 AD v2.0 Conversion from F77 to F90 ! 23JUL15 AD v1.0 Original. ! ! DESCRIPTION ! Program to merge .grd irregular grid files ! Output file is union of input files spanning max range. ! MODULE MRGGRD_MOD ! ! VARIABLE KINDS INTEGER, PARAMETER :: I1 = SELECTED_INT_KIND(1) INTEGER, PARAMETER :: I4 = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: R4 = SELECTED_REAL_KIND(6) INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND(15,200) ! ! GLOBAL CONSTANTS CHARACTER(7), PARAMETER :: VERSID = '2.0' ! Program version identifier INTEGER(I4), PARAMETER :: LUNGRD = 1 ! LUN for reading/writing INTEGER(I4), PARAMETER :: MAXFIL = 10 ! Max.no files to merge ! CONTAINS ! SUBROUTINE REAGRD ( LUNGRD, FILNAM, WNOD, WNO1, WNO2, IFLAG ) ! ! VERSION ! 11JUN19 AD Converted from F77 to F90 ! 03DEC14 AD Original ! ! DESCRIPTION ! Read in data from .grd irregular grid file ! IMPLICIT NONE ! ! ARGUMENTS INTEGER(I4), INTENT(IN) :: LUNGRD ! LUN for reading in data CHARACTER(*), INTENT(IN) :: FILNAM ! Name of file REAL(R8), INTENT(INOUT) :: WNOD ! Wno. increment [cm-1] of full grid REAL(R8), INTENT(OUT) :: WNO1 ! Wno. [cm-1] at start of full grd REAL(R8), INTENT(OUT) :: WNO2 ! Wno. [cm-1] at end of full grd INTEGER(I1), OPTIONAL, ALLOCATABLE, & INTENT(OUT) :: IFLAG(:) ! Irreg Grid points, 1=used ! ! LOCAL VARIABLES INTEGER(I4) :: ICHAR ! Counter for hex characters within record (1:50) INTEGER(I4) :: IGRD ! Counter for full grid points INTEGER(I4) :: IHEX ! Integer value of hexadecimal character INTEGER(I4) :: ITWO ! Factors of two for selecting hex bits INTEGER(I4) :: IOS ! Saved value of IOSTAT for error messages INTEGER(I4) :: NGRD ! No.pts in full grid INTEGER(I4) :: NUSE ! Number of irreg.grid points represented REAL(R8) :: WNODF ! Wno.spacing [cm-1] read from file CHARACTER(50) :: REC50 ! Grid record read from file ! ! EXECUTABLE CODE ------------------------------------------------------------- ! OPEN ( UNIT=LUNGRD, FILE=FILNAM, STATUS='OLD', ACTION='READ', & IOSTAT=IOS, ERR=900 ) READ ( LUNGRD, '(A)', IOSTAT=IOS, ERR=900 ) REC50 DO READ ( LUNGRD, '(A)', IOSTAT=IOS, ERR=900 ) REC50 IF ( REC50(1:1) .NE. '!' ) EXIT END DO ! READ ( LUNGRD, *, IOSTAT=IOS, ERR=900 ) NGRD, NUSE, WNO1, WNODF IF ( WNOD .EQ. 0.0D0 ) THEN WNOD = WNODF ELSE IF ( ABS ( WNODF - WNOD ) .GT. 0.001 * WNOD ) THEN STOP 'F-REAGRD: Irr.grid files on different wavenumber spacing' ENDIF WNO2 = WNO1 + ( NGRD - 1 ) * WNOD READ ( LUNGRD, '(A)', IOSTAT=IOS, ERR=900 ) REC50 ! IF ( PRESENT ( IFLAG ) ) THEN ALLOCATE ( IFLAG(NGRD) ) IFLAG = 0 DO IGRD = 1, NGRD IF ( MOD ( IGRD, 200 ) .EQ. 1 ) THEN READ ( LUNGRD, '(A)', IOSTAT=IOS, ERR=900 ) REC50 ICHAR = 0 END IF IF ( MOD ( IGRD, 4 ) .EQ. 1 ) THEN ICHAR = ICHAR + 1 READ ( REC50(ICHAR:ICHAR), '(Z1)', IOSTAT=IOS, ERR=900 ) IHEX ITWO = 16 ENDIF ITWO = ITWO/2 IF ( IHEX .GE. ITWO ) THEN IFLAG(IGRD) = 1 IHEX = IHEX - ITWO END IF END DO END IF ! CLOSE ( LUNGRD, IOSTAT=IOS, ERR=900 ) ! 900 CONTINUE IF ( IOS .NE. 0 ) THEN WRITE ( *, * ) 'F-REAGRD: I/O error reading file, IOSTAT=', IOS STOP END IF ! END SUBROUTINE REAGRD END MODULE MRGGRD_MOD PROGRAM MRGGRD ! ! DESCRIPTION ! Main program. ! USE MRGGRD_MOD ! IMPLICIT NONE ! ! LOCAL VARIABLES INTEGER(I4) :: ICHAR ! Hexadecimal character within output record INTEGER(I4) :: IFIL ! Counter for input .grd files to be merged INTEGER(I4) :: IFLG ! Counter for irr.grd points from input file INTEGER(I4) :: IGRD ! Counter for full grid points INTEGER(I4) :: IOFF ! Offset for merging grd file with full grid INTEGER(I4) :: IOS ! Saved value of IOSTAT for error messages INTEGER(I4) :: IPT ! Pointer to last character in filenames INTEGER(I4) :: ISUM ! Summation for conversion to decimal INTEGER(I4) :: ITWO ! Power of two for conversion to hexadecimal INTEGER(I4) :: NFIL = 0 ! No. of files to be merged INTEGER(I4) :: NGRD ! Total number of regular grid points required INTEGER(I4) :: NUSE ! No. 'set' grid points in output file REAL(R8) :: WN1FIL ! Lower wavenumber [cm-1] of .grd files REAL(R8) :: WN2FIL ! Upper wavenumber [cm-1] of .grd files REAL(R8) :: WND = 0.0D0 ! Wavenumber increment [cm-1] in .grd files REAL(R8) :: WNOMAX = 0.0D0 ! Upper Wno [cm-1] of output .grd file REAL(R8) :: WNOMIN = 1.0D6 ! Lower Wno [cm-1] of output .grd file CHARACTER(80) :: ANSWER ! User response CHARACTER(200) :: FILLST(MAXFIL) ! List of filenames for merging CHARACTER(200) :: FILNAM ! Filename CHARACTER(50) :: REC50 ! Hexadecimal coded output record INTEGER(I1), ALLOCATABLE :: IGRID(:) ! Output Irreg.grid INTEGER(I1), ALLOCATABLE :: IFLAG(:) ! Irreg.grid from file ! ! EXECUTABLE CODE ------------------------------------------------------------- ! WRITE ( *, '(A)' ) 'R-MRGGRD: Running MRGGRD v.'//VERSID ! ! Open files and read in spectra WRITE ( *, '(A,I3,A)' ) 'Input .grd filenames (max=', MAXFIL, & ') ending with ' DO IFIL = 1, MAXFIL WRITE ( *, '(A,I3,A)', ADVANCE='NO' ) 'File#', IFIL, ': ' READ ( *, '(A)' ) FILNAM IF ( FILNAM .EQ. '' ) EXIT NFIL = NFIL + 1 FILLST(NFIL) = FILNAM CALL REAGRD ( LUNGRD, FILNAM, WND, WN1FIL, WN2FIL ) WNOMIN = MIN ( WNOMIN, WN1FIL ) WNOMAX = MAX ( WNOMAX, WN2FIL ) END DO ! WRITE ( *, '(AF10.4,A,F10.4,A)' ) & 'Spectral range (=', WNOMIN, ':', WNOMAX, ' [cm-1]): ' READ ( *, '(A)', IOSTAT=IOS ) ANSWER IF ( ANSWER .NE. '' ) READ ( ANSWER, *, IOSTAT=IOS, ERR=900 ) WNOMIN, WNOMAX ! NGRD = NINT ( ( WNOMAX - WNOMIN ) / WND ) + 1 ALLOCATE ( IGRID(NGRD) ) IGRID = 0 IGRID(1) = 1 IGRID(NGRD) = 1 ! WRITE ( *, '(A)', ADVANCE='NO' ) 'Output file: ' READ ( *, '(A)' ) FILNAM ! ! Read through files, adding grid points with appropriate offset DO IFIL = 1, NFIL CALL REAGRD ( LUNGRD, FILLST(IFIL), WND, WN1FIL, WN2FIL, IFLAG ) IOFF = NINT ( ( WN1FIL - WNOMIN ) / WND ) DO IFLG = 1, SIZE ( IFLAG ) IGRD = IOFF + IFLG IF ( IGRD .LE. 0 ) CYCLE IF ( IGRD .GT. NGRD ) EXIT IF ( IFLAG(IFLG) .EQ. 1 ) IGRID(IGRD) = 1 END DO DEALLOCATE ( IFLAG ) END DO ! ! NB IGRID is byte so can't use SUM since this will also be byte NUSE = COUNT ( IGRID .EQ. 1 ) ! WRITE ( *, '(A,2F10.4,A)' ) 'New grid: Range=', WNOMIN, WNOMAX, ' [cm-1]' WRITE ( *, '(A,2I7,F7.2,A)' ) 'Total, Used pts=', NGRD, NUSE, & 100*FLOAT(NUSE)/FLOAT(NGRD),'%' ! OPEN ( UNIT=LUNGRD, FILE=FILNAM, STATUS='UNKNOWN', ACTION='WRITE', & ERR=900, IOSTAT=IOS ) WRITE ( LUNGRD, '(A)' ) & '! Merged irregular grid created by program MRGGRD v.' // VERSID DO IFIL = 1, NFIL IPT = INDEX ( FILLST(IFIL)//' ', ' ' ) - 1 WRITE ( LUNGRD, '(A)' ) '! '//FILLST(IFIL)(1:IPT) END DO WRITE ( LUNGRD, '(A,2I6,F5.1,A)' ) & 'lin ', NGRD, NUSE, FLOAT(NUSE) / FLOAT(NGRD) * 100.0, & ' = Fnc, N.Orig, N.Used, %Used' WRITE ( LUNGRD, '(2I10,F10.3,F10.4,A)' ) NGRD, NUSE, WNOMIN, WND, & ' = N.Pts, N.Used, 1st Wno, Wno increment' WRITE ( LUNGRD, '(2F10.1,A)' ) 0.0, 120.0, & ' = Min/Max tangent height altitudes' ! ITWO = 16 ISUM = 0 ICHAR = 0 DO IGRD = 1, NGRD ITWO = ITWO/2 ISUM = ISUM + ITWO * IGRID(IGRD) IF ( MOD ( IGRD, 4 ) .EQ. 0 .OR. IGRD .EQ. NGRD ) THEN ICHAR = ICHAR + 1 WRITE ( REC50(ICHAR:ICHAR), '(Z1)' ) ISUM ISUM = 0 ITWO = 16 IF ( ICHAR .EQ. 50 .OR. IGRD .EQ. NGRD ) THEN WRITE ( LUNGRD, '(A50)' ) REC50 WRITE ( REC50, '(50X)' ) ICHAR = 0 END IF END IF END DO CLOSE ( LUNGRD ) ! 900 CONTINUE IF ( IOS .NE. 0 ) THEN WRITE ( *, * ) 'F-REAGRD: I/O error reading file, IOSTAT=', IOS STOP END IF ! WRITE ( *, '(A)' ) 'R-MRGGRD: Successful Completion' ! END PROGRAM MRGGRD