!+ Program to assemble grey gaseous extinction data.
!
! Method:
!	Band strengths of absorption are read in together with the 
!	ambient conditions. These data are converted to an ESFT fit
!	of one term which is written out in a form appropriate for
!	reading into a spectral file.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!	Version		Date		Comment
!	1.0		12-04-95	First Version under RCS
!					(J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77 with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
      PROGRAM GREY_FIT
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/gas_list.pcf'
      INCLUDE 'incl/gas_list.ncf'
      INCLUDE 'incl/physical_constants_1.ccf'
      INCLUDE 'incl/esft_scale.pcf'
      INCLUDE 'incl/scale_fnc.pcf'
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/def_pp_io.icf'
      INCLUDE 'incl/file_type.pcf'
      INCLUDE 'incl/error.pcf'
!
!     DECLARATION OF VARIABLES
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
      CHARACTER
     &     UNIT*20
!             UNIT FOR INTENSITY
     &   , CHAR_YN*1
!             RESPONSE TO QUESTION
     &   , FILE_SPECTRAL*80
!             NAME OF SPECTRAL FILE
      INTEGER
     &     IERR
!             ERROR FLAG
     &   , I_BAND
!             BAND BEING CONSIDERED
     &   , I_INDEX
!             INDEX OF GAS
     &   , I_GAS
!             TYPE OF GAS
     &   , IOS
!             I/O ERROR FLAG
     &   , J
!             LOOP VARIABLE
      LOGICAL
     &     L_IN_BAND
!             TRUE IF GAS ABSORBS IN GIVEN BAND
      REAL*8
     &     INTENSITY
!             INTEGRATED INTENSITY OF GAS
     &   , PRESSURE
!             PRESSURE OF MEASUREMENT
     &   , TEMPERATURE
!             TEMPERATURE OF MEASUREMENT
     &   , K_ABSORB
!             ABSORPTION COEFFICIENT ACROSS BAND
     &   , DELTA_NU
!             DIFFERENCE IN FREQUENCY ACROSS BAND
!
!     DECLARATION OF SPECTRAL QUANTITIES.
      INCLUDE 'dec_spec.finc'
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     IN_SPECTRUM, OPEN_FILE_OUT
!
!
      DATA IERR/I_NORMAL/
!
      INCLUDE 'incl/gas_names.dcf'
      INCLUDE 'incl/scale_fnc.dcf'
      INCLUDE 'incl/gas_molar_weight.ccf'
!
!
!
100   WRITE(IU_USER, '(/A)')
     &   'ENTER THE NAME OF THE SPECTRAL FILE.'
      READ(IU_STDIN, '(A)') FILE_SPECTRAL
      INCLUDE 'read_spec.finc'
      IF (IERR.NE.I_NORMAL) THEN
         IF (IERR.EQ.I_ERR_EXIST) THEN
            IERR=I_NORMAL
            GOTO 100
         ELSE
            STOP
         ENDIF
      ENDIF
!
!     OPEN THE OUTPUT FILE.
      CALL OPEN_FILE_OUT(IERR, IU_ESFT_OUT
     &   , 'ENTER NAME OF OUTPUT FILE.')
      IF (IERR.NE.I_NORMAL) STOP
!
1        WRITE(IU_USER, '(/A)')
     &      'ENTER BAND IN WHICH GREY DATA ARE TO BE SUPPLIED.'
         READ(IU_STDIN, *, IOSTAT=IOS) I_BAND
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ ERRONEOUS RESPONSE.'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 1
            ENDIF
         ENDIF
         IF ( (I_BAND.LE.0).OR.(I_BAND.GT.N_BAND) ) THEN
            WRITE(IU_ERR, '(/A)') '+++ BAND IS OUT OF RANGE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 1
            ENDIF
         ENDIF
!
2        WRITE(IU_USER, '(/A)')
     &      'ENTER TYPE NUMBER OF GAS FOR WHICH EXTINCTION '
     &      //'IS TO BE GIVEN.'
         READ(IU_STDIN, *, IOSTAT=IOS) I_GAS
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ ERRONEOUS RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 2
            ENDIF
         ENDIF
         L_IN_BAND=.FALSE.
         DO J=1, N_BAND_ABSORB(I_BAND)
            IF (TYPE_ABSORB(INDEX_ABSORB(J, I_BAND)).EQ.I_GAS) THEN
               L_IN_BAND=.TRUE.
               I_INDEX=INDEX_ABSORB(J, I_BAND)
            ENDIF
         ENDDO
         IF (.NOT.L_IN_BAND) THEN
            WRITE(IU_ERR, '(A4, A20, A)') '+++ ', NAME_ABSORB(I_GAS)
     &         , ' IS NOT IN BAND:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 2
            ENDIF
         ENDIF
!
3        WRITE(IU_USER, '(/A)') 'ENTER INTEGRATED INTENSITY ACROSS BAND'
     &      //' AND UNIT.'
         WRITE(IU_USER, '(A)') 'SELECT THE UNIT FROM THE LIST BELOW:'
         WRITE(IU_USER, '(A)') '   M-2.PA-1 -- INVERSE SQUARE METRES '
     &      //'PER PASCAL.'
         WRITE(IU_USER, '(A)') '   CM-2.ATM-1 -- INVERSE SQUARE '
     &      //'CENTIMETRES PER ATMOSPHERE.'
         READ(IU_STDIN, *, IOSTAT=IOS) INTENSITY, UNIT
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ ERRONEOUS INPUT:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 3
            ENDIF
         ENDIF
!
         IF ( (UNIT(1:8).EQ.'M-2.PA-1').OR.
     &      (UNIT(1:8).EQ.'m-2.pa-1') ) THEN
            CONTINUE
         ELSE IF ( (UNIT(1:10).EQ.'CM-2.ATM-1').OR.
     &       (UNIT(1:10).EQ.'cm-2.atm-1') ) THEN
            INTENSITY=INTENSITY*1.0D+04/101325.0D+00
         ELSE
            WRITE(IU_ERR, '(A)') '+++ INVALID UNIT.'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 3
            ENDIF
         ENDIF
!
4        WRITE(IU_USER, '(/A)')
     &      'ENTER PRESSURE AND ABSOLUTE TEMPERATURE '
     &      //'AT WHICH DATA ARE GIVEN.'
         READ(IU_STDIN, *, IOSTAT=IOS) PRESSURE, TEMPERATURE
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(/A)') '+++ ERRONEOUS RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 4
            ENDIF
         ENDIF
!
!        CONVERT TO A FINAL ABSORPTION COEFFICIENT.
         DELTA_NU=1.0D+00/WAVE_LENGTH_SHORT(I_BAND)
     &      -1.0D+00/WAVE_LENGTH_LONG(I_BAND)
         IF (L_PRESENT(14)) THEN
!           REMOVE EXCLUDED CONTRIBUTIONS.
            DO J=1, N_BAND_EXCLUDE(I_BAND)
               DELTA_NU=DELTA_NU-
     &            (1.0D+00/WAVE_LENGTH_SHORT(INDEX_EXCLUDE(J, I_BAND))
     &            -1.0D+00/WAVE_LENGTH_LONG(INDEX_EXCLUDE(J, I_BAND)))
            ENDDO
         ENDIF
         K_ABSORB=R_GAS*TEMPERATURE*INTENSITY
     &      /(MOLAR_WEIGHT(I_GAS)*DELTA_NU)
!
!        WRITE THE DATA IN THE SAME FORMAT AS AN ESFT.
         WRITE(IU_ESFT_OUT, '(A13, I5, //A)') '*FILE TYPE = '
     &      , IT_FILE_LINE_FIT
     &      , 'GREY GASEOUS EXPONENTIAL SUM FIT.'
         WRITE(IU_ESFT_OUT, '(6X, A8, I5, A21, I5)')
     &      'IN BAND ', I_BAND, ': FOR ABSORBER INDEX ', I_INDEX
         WRITE(IU_ESFT_OUT, '(6X, A12, 1PE10.3, A21, 1PE10.3, A3)')
     &      'AT PRESSURE ', PRESSURE, ' Pa, AND TEMPERATURE '
     &      , TEMPERATURE, ' K.'
         WRITE(IU_ESFT_OUT, '(//A)')
     &      'GREY FIT WITH NO SCALING PARAMETERS.'
!
         WRITE(IU_ESFT_OUT, '(/)')
!
         WRITE(IU_ESFT_OUT, '(5X, A18, I5, A20, I5, A21, I5)')
     &      'NUMBER OF TERMS = ', 1, ': TYPE OF SCALING = '
     &      , IP_SCALE_NULL
     &      , ': SCALING FUNCTION = ', IP_SCALE_FNC_NULL
         WRITE(IU_ESFT_OUT, '(4X, A8, 12X, A6)')
     &      'EXPONENT', 'WEIGHT'
         WRITE(IU_ESFT_OUT, '(5X, A5)') 'm2/kg'
         WRITE(IU_ESFT_OUT, '(2(3X, 1PE16.9)
     &        , (T39, 2(3X, 1PE16.9)))')
     &          K_ABSORB, 1.0D+00
!
         WRITE(IU_ESFT_OUT, '(/)')
!
7        WRITE(IU_USER, '(//A)')
     &      'DO YOU WISH TO SUPPLY DATA FOR ANOTHER GAS? (Y/N)'
         READ(IU_STDIN, '(A)') CHAR_YN
         IF ( (CHAR_YN.EQ.'Y').OR.(CHAR_YN.EQ.'y') ) THEN
            GOTO 1
         ELSE IF ( (CHAR_YN.EQ.'N').OR.(CHAR_YN.EQ.'n') ) THEN
            CLOSE(IU_ESFT_OUT)
         ELSE
            WRITE(IU_ERR, '(/A)') '+++ INVALID RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 7
            ENDIF
         ENDIF
!
!
      STOP
      END
