!+ Subroutine to add data to the spectral file.
!
!
! Method:
!	A spectral file is read in and the user then selects
!	a block of data to add to the file. The resulting file
!	is then written out.
!
! 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 PREP_DATA
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/def_spc_io.icf'
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/dimensions_pp.ucf'
      INCLUDE 'incl/continuum.pcf'
      INCLUDE 'incl/error.pcf'
!
!     DECLARATION OF VARIABLES.
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
      CHARACTER
     &     FILE_SPECTRAL*80
!             NAME OF SPECTRAL FILE
     &   , CHAR_QNA*1
!             CHARACTER RESPONSE VARIABLE
     &   , CHAR_YN*1
!             CHARACTER RESPONSE VARIABLE
      INTEGER
     &     IERR
!             ERROR FLAG
      INTEGER
     &     I_BLOCK
!             TYPE OF BLOCK TO BE MADE
     &   , IOS
!             ERROR FLAG
     &   , N_SOLAR_POINTS
!             POINTS IN SOLAR SPECTRUM
      LOGICAL
     &     L_SOLAR_SPECTRUM
!             FLAG FOR SOLAR SPECTRUM
     &   , L_EXIST
!             EXISTENCE FLAG FOR FILE
      REAL*8
     &     SOLAR_WAVELENGTH(NPD_SOLAR_POINTS)
!             SOLAR WAVELENGTHS
     &   , SOLAR_IRRAD(NPD_SOLAR_POINTS)
!             SOLAR IRRADIANCE
!
!     INCLUDE DECLARATIONS OF SPECTRAL DATA.
      INCLUDE 'dec_spec.finc'
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     IN_SPECTRUM, OUT_SPECTRUM, MAKE_BLOCK_2, MAKE_BLOCK_3
     &   , MAKE_BLOCK_5, MAKE_BLOCK_6, MAKE_BLOCK_7
     &   , MAKE_BLOCK_9, MAKE_BLOCK_10, MAKE_BLOCK_11
     &   , MAKE_BLOCK_12, MAKE_BLOCK_13
!
!
!     INITIALIZE TO CONDITION OF NO ERRORS.
      DATA IERR/I_NORMAL/
      DATA L_SURFACE/NPD_SURFACE*.FALSE./
     &   , L_DROP_TYPE/NPD_DROP_TYPE*.FALSE./
!
!
!
!     OBTAIN THE SPECTRAL DATA FROM THE PARTIALLY COMPLETED SPECTRAL
!     DATA FILE.
      WRITE(IU_USER, '(/A)')
     &   '   This program receives a partially completed spectral data'
      WRITE(IU_USER, '(A)')
     &   'file and adds blocks of data to it from other available data'
      WRITE(IU_USER, '(A)')
     &   'files.'
100   WRITE(IU_USER, '(/A)')
     &   'NAME OF BASIC SPECTRAL DATA FILE ?'
      READ(IU_STDIN, '(A)') FILE_SPECTRAL
!
      INCLUDE 'read_spec.finc'
!
      IF (IERR.NE.I_NORMAL) THEN
         IF (IERR.EQ.I_ERR_EXIST) THEN
!           RESET THE ERROR FLAG TO THE NORMAL CONDITION SINCE
!           CORRECTIVE ACTION IS ABOUT TO BE TAKEN.
            IERR=I_NORMAL
            GOTO 100
         ELSE
            STOP
         ENDIF
      ENDIF
!
!     DETERMINE WHETHER DATA ARE TO BE APPENDED TO THE OLD FILE,
!     OR WHETHER A NEW FILE IS TO BE WRITTEN.
      WRITE(IU_USER, '(/A)') 'TYPE'
      WRITE(IU_USER, '(6X, A)')
     &   '"A" TO APPEND DATA TO THE EXISTING FILE;'
      WRITE(IU_USER, '(6X, A)')
     &   '"N" TO CREATE A NEW FILE;'
      WRITE(IU_USER, '(6X, A)')
     &   '"Q" TO QUIT.'
      WRITE(IU_USER, '(/)')
1     READ(IU_STDIN, '(A)') CHAR_QNA
      IF ( (CHAR_QNA.EQ.'A').OR.(CHAR_QNA.EQ.'a') ) THEN
         CONTINUE
      ELSE IF ( (CHAR_QNA.EQ.'N').OR.(CHAR_QNA.EQ.'n') ) THEN
         WRITE(IU_USER, '(A)') 'ENTER THE NAME OF THE NEW FILE'
2        READ(IU_STDIN, '(A)') FILE_SPECTRAL
!        CHECK FOR EXISTENCE OF FILE.
         INQUIRE(FILE=FILE_SPECTRAL, EXIST=L_EXIST)
         IF (L_EXIST) THEN
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(/A)') 'THIS FILE ALREADY EXISTS: '
     &            //'DO YOU WISH TO OVERWRITE? (Y/N)'
3              READ(IU_STDIN, '(A)') CHAR_YN
               IF ( (CHAR_YN.EQ.'N').OR.(CHAR_YN.EQ.'n') ) THEN
                  WRITE(IU_USER, '(A)') 'PLEASE SPECIFY ANOTHER FILE.'
                  GOTO 2
               ELSE IF ( (CHAR_YN.NE.'Y').AND.(CHAR_YN.NE.'y') ) THEN
                  WRITE(IU_USER, '(A)')
     &               '+++ ILLEGAL RESPONSE: PLEASE RETYPE.'
                  GOTO 3
               ENDIF
            ENDIF
         ENDIF
      ELSE IF ( (CHAR_QNA.EQ.'Q').OR.(CHAR_QNA.EQ.'q') ) THEN
         STOP
      ELSE
         WRITE(IU_ERR, '(A)') '+++ ERRONEOUS RESPONSE:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-TYPE.'
            GOTO 1
         ENDIF
      ENDIF
!
!     NOW DECIDE WHICH BLOCKS ARE TO BE WRITTEN.
4     WRITE(IU_USER, '(/A)')
     &   'SELECT FROM THE FOLLOWING TYPES OF DATA.'
!
      WRITE(IU_USER, '(/6X, A)')
     &   '2.   BLOCK 2: SOLAR SPECTRUM IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '3.   BLOCK 3: RAYLEIGH SCATTERING IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '5.   BLOCK 5: ESFT AND P, T SCALING DATA.'
      WRITE(IU_USER, '(6X, A)')
     &   '6.   BLOCK 6: THERMAL SOURCE FUNCTION IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '7.   BLOCK 7: SURFACE PROPERTIES IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '9.   BLOCK 9: CONTINUUM EXTINCTION AND SCALING DATA.'
      WRITE(IU_USER, '(6X, A)')
     &   '10.  BLOCK 10: DROPLET PARAMETERS IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '11.  BLOCK 11: AEROSOL PARAMETERS IN EACH BAND.'
      WRITE(IU_USER, '(6X, A)')
     &   '12.  BLOCK 12: ICE CRYSTAL PARAMETERS IN EACH BAND.'
      WRITE(IU_USER, '(6X, A/)')
     &   '13.  BLOCK 13: DOPPLER BROADENING DATA FOR EACH GAS.'
      WRITE(IU_USER, '(/5X, A//)')
     &   '-1.  TO FINISH.'
5     READ(IU_STDIN, *, IOSTAT=IOS) I_BLOCK
      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 RE-TYPE.'
            GOTO 5
         ENDIF
      ENDIF
!
!     CHECK WHETHER THE BLOCK IS PRESENT AND REQUEST CONFIRMATION
!     FOR OVERWRITING. BLOCK 7 IS NOT CHECKED SINCE MULTIPLE COPIES
!     ARE PERMITTED.
      IF ( (I_BLOCK.NE.-1)
     &   .AND.(I_BLOCK.NE.7)
     &   .AND.(I_BLOCK.NE.10)
     &   .AND.(I_BLOCK.NE.11)
     &   .AND.(I_BLOCK.NE.12) ) THEN
         IF (L_PRESENT(I_BLOCK)) THEN
            WRITE(IU_ERR, '(/A)') 'THIS BLOCK ALREADY EXISTS'
            IF (.NOT.LOCK_CODE(.TRUE.)) THEN
               WRITE(IU_USER, '(A/)') 'CONTINUE ? (Y/N)'
               READ(IU_STDIN, '(A)') CHAR_YN
               IF ( (CHAR_YN.NE.'Y').AND.(CHAR_YN.NE.'y') ) GOTO 4
            ENDIF
         ENDIF
      ENDIF
!
!     FOR EACH VALID TYPE OF BLOCK CALL THE APPROPRIATE ROUTINE.
      IF (I_BLOCK.EQ.-1) THEN
!        WRITE OUT THE SPECTRAL FILE.
         CALL OUT_SPECTRUM(IERR
     &      , FILE_SPECTRAL, L_PRESENT
     &      , N_BAND, N_ABSORB, N_BAND_ABSORB, INDEX_ABSORB, TYPE_ABSORB
     &      , N_AEROSOL, TYPE_AEROSOL
     &      , N_BAND_CONTINUUM, INDEX_CONTINUUM, INDEX_WATER
     &      , I_BAND_ESFT, K_ESFT, W_ESFT, I_SCALE_ESFT
     &      , I_SCALE_FNC, SCALE_VECTOR, P_REFERENCE, T_REFERENCE
     &      , WAVE_LENGTH_SHORT , WAVE_LENGTH_LONG
     &      , N_BAND_EXCLUDE, INDEX_EXCLUDE
     &      , SOLAR_FLUX_BAND
     &      , N_DEG_FIT, THERMAL_COEFFICIENT, T_REF_PLANCK
     &      , RAYLEIGH_COEFFICIENT
     &      , I_SPEC_SURFACE, SURFACE_ALBEDO, N_DIR_ALBEDO_FIT
     &      , DIRECT_ALBEDO_PARM, EMISSIVITY_GROUND, L_SURFACE
     &      , K_CONTINUUM, I_SCALE_FNC_CONT, SCALE_CONTINUUM
     &      , P_REF_CONTINUUM, T_REF_CONTINUUM
     &      , L_DROP_TYPE, I_DROP_PARAMETRIZATION, DROP_PARAMETER_LIST
     &      , N_DROP_DATA_LAYER, DROP_PRESSURE
     &      , DROP_ABSORPTION, DROP_SCATTERING, DROP_ASYMMETRY
     &      , L_ICE_TYPE, I_ICE_PARAMETRIZATION
     &      , ICE_PARAMETER_LIST
     &      , N_ICE_DATA_LAYER, ICE_PRESSURE
     &      , ICE_ABSORPTION, ICE_SCATTERING
     &      , ICE_ASYMMETRY
     &      , L_AEROSOL_SPECIES, AEROSOL_ABSORPTION
     &      , AEROSOL_SCATTERING, AEROSOL_ASYMMETRY
     &      , NHUMIDITY, HUMIDITIES
     &      , I_AEROSOL_PARAMETRIZATION
     &      , N_AEROSOL_DATA_LAYER, OBS_AEROSOL_PRESSURE
     &      , OBS_AEROSOL_ABSORPTION, OBS_AEROSOL_SCATTERING
     &      , OBS_AEROSOL_ASYMMETRY
     &      , L_DOPPLER_PRESENT, DOPPLER_CORRECTION
     &      )
         WRITE(IU_USER, '(/A/)') 'PROGRAM TERMINATED.'
         CLOSE(IU_SPC)
         STOP
      ELSE IF (I_BLOCK.EQ.2) THEN
         CALL MAKE_BLOCK_2(IERR
     &      , N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &      , L_PRESENT(14), N_BAND_EXCLUDE, INDEX_EXCLUDE
     &      , L_SOLAR_SPECTRUM, N_SOLAR_POINTS
     &      , SOLAR_WAVELENGTH, SOLAR_IRRAD
     &      , SOLAR_FLUX_BAND, L_PRESENT(2)
     &      )
      ELSE IF (I_BLOCK.EQ.3) THEN
         CALL MAKE_BLOCK_3(IERR
     &      , N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &      , L_SOLAR_SPECTRUM, N_SOLAR_POINTS
     &      , SOLAR_WAVELENGTH, SOLAR_IRRAD
     &      , RAYLEIGH_COEFFICIENT, L_PRESENT(3)
     &      )
      ELSE IF (I_BLOCK.EQ.5) THEN
         CALL MAKE_BLOCK_5(IERR
     &      , N_BAND, N_ABSORB, N_BAND_ABSORB, INDEX_ABSORB
     &      , I_BAND_ESFT, W_ESFT, K_ESFT, I_SCALE_ESFT
     &      , I_SCALE_FNC, SCALE_VECTOR, P_REFERENCE, T_REFERENCE
     &      , L_PRESENT(5)
     &      )
      ELSE IF (I_BLOCK.EQ.6) THEN
         CALL MAKE_BLOCK_6(IERR
     &      , N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &      , L_PRESENT(14), N_BAND_EXCLUDE, INDEX_EXCLUDE
     &      , N_DEG_FIT, T_REF_PLANCK, THERMAL_COEFFICIENT
     &      , L_PRESENT(6)
     &      )
      ELSE IF (I_BLOCK.EQ.7) THEN
         CALL MAKE_BLOCK_7(IERR
     &      , N_BAND
     &      , L_SURFACE, I_SPEC_SURFACE, SURFACE_ALBEDO
     &      , N_DIR_ALBEDO_FIT, DIRECT_ALBEDO_PARM
     &      , EMISSIVITY_GROUND
     &      , L_PRESENT(7)
     &      )
      ELSE IF (I_BLOCK.EQ.9) THEN
         CALL MAKE_BLOCK_9(IERR
     &      , N_BAND, N_BAND_CONTINUUM, INDEX_CONTINUUM
     &      , K_CONTINUUM, I_SCALE_FNC_CONT, SCALE_CONTINUUM
     &      , P_REF_CONTINUUM, T_REF_CONTINUUM
     &      , L_PRESENT(9)
     &      )
      ELSE IF (I_BLOCK.EQ.10) THEN
         CALL MAKE_BLOCK_10(IERR
     &      , N_BAND
     &      , L_DROP_TYPE, I_DROP_PARAMETRIZATION
     &      , DROP_PARAMETER_LIST
     &      , N_DROP_DATA_LAYER, DROP_PRESSURE
     &      , DROP_ABSORPTION, DROP_SCATTERING, DROP_ASYMMETRY
     &      , L_PRESENT(10)
     &      )
      ELSE IF (I_BLOCK.EQ.11) THEN
         CALL MAKE_BLOCK_11(IERR
     &      , N_BAND, N_AEROSOL, TYPE_AEROSOL
     &      , I_AEROSOL_PARAMETRIZATION
     &      , AEROSOL_ABSORPTION, AEROSOL_SCATTERING
     &      , AEROSOL_ASYMMETRY
     &      , NHUMIDITY, HUMIDITIES
     &      , N_AEROSOL_DATA_LAYER, OBS_AEROSOL_PRESSURE
     &      , OBS_AEROSOL_ABSORPTION, OBS_AEROSOL_SCATTERING
     &      , OBS_AEROSOL_ASYMMETRY
     &      , L_AEROSOL_SPECIES
     &      , L_PRESENT(11)
     &      )
      ELSE IF (I_BLOCK.EQ.12) THEN
         CALL MAKE_BLOCK_12(IERR
     &      , N_BAND
     &      , L_ICE_TYPE, I_ICE_PARAMETRIZATION
     &      , ICE_PARAMETER_LIST
     &      , N_ICE_DATA_LAYER, ICE_PRESSURE
     &      , ICE_ABSORPTION, ICE_SCATTERING
     &      , ICE_ASYMMETRY
     &      , L_PRESENT(12)
     &      )
      ELSE IF (I_BLOCK.EQ.13) THEN
         CALL MAKE_BLOCK_13(IERR
     &      , N_ABSORB, TYPE_ABSORB
     &      , L_DOPPLER_PRESENT, DOPPLER_CORRECTION
     &      , L_PRESENT(13)
     &      )
      ELSE
         WRITE(IU_ERR, '(A)') '+++ INVALID BLOCK NUMBER:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-TYPE.'
            GOTO 5
         ENDIF
      ENDIF
      IF (IERR.NE.I_NORMAL) STOP
!
      WRITE(IU_USER, '(/A/)') 'SPECIFY NEXT BLOCK NUMBER.'
      GOTO 4
!
!
      END
