!+ Program to prepare a skeletal spectral file.
!
! Method:
!	The user is asked to supply the limits on the spectral bands
!	and the gases and aerosols present in 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 PREP_SPECTRUM
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/def_spc_io.icf'
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/gas_list.pcf'
      INCLUDE 'incl/error.pcf'
!
!
!     DECLARATION OF VARIABLES.
      INTEGER
     &     IERR
!             ERROR FLAG
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
!     ELEMENTS OF SPECTRUM
!
      INTEGER
     &     N_BAND
!             NUMBER OF SPECTRAL BANDS
!
!     EXCLUDED BANDS
      LOGICAL
     &     L_EXCLUDE
!             FLAG FOR EXCLUSION OF BANDS
      INTEGER
     &     N_BAND_EXCLUDE(NPD_BAND)
!             NUMBER OF EXCLUDED BANDS IN EACH BAND
     &   , INDEX_EXCLUDE(NPD_EXCLUDE, NPD_BAND)
!             ARRAY OF INDICES OF EXCLUDED BANDS
!
!     GASEOUS ABSORPTION
      INTEGER
     &     N_ABSORB
!             NUMBER OF ABSORBERS
     &   , TYPE_ABSORB(NPD_SPECIES)
!             TYPE NUMBERS OF ABSORBER
     &   , TYPE_INDEX(NPD_GASES)
!             INDEX NUMBERS FOR GASES
     &   , INDEX_WATER
!             INDEX OF WATER
     &   , N_BAND_ABSORB(NPD_BAND)
!             NUMBER OF ABSORBERS IN EACH BAND
     &   , INDEX_ABSORB(NPD_SPECIES, NPD_BAND)
!             ARRAY OF INDICES FOR ABSORBERS
!
!     CONTINUUM PROCESSES
      INTEGER
     &     N_BAND_CONTINUUM(NPD_BAND)
!             NUMBER OF CONTINUA IN BANDS
     &   , INDEX_CONTINUUM(NPD_BAND, NPD_CONTINUUM)
!             INDICES OF CONTINUA
!
!     AEROSOLS
      INTEGER
     &     N_AEROSOL
!             NUMBER OF AEROSOLS
     &   , TYPE_AEROSOL(NPD_AEROSOL_SPECIES)
!             TYPES OF AEROSOLS
      REAL*8
     &     WAVE_LENGTH_SHORT(NPD_BAND)
!             SHORTER LIMITS OF BANDS
     &   , WAVE_LENGTH_LONG(NPD_BAND)
!             LONGER LIMITS OF BANDS
!
!
!     CONTROLLING VARIABLES
      CHARACTER
     &     CHAR_IF
!             VARIABLE SETTING TYPE OF INPUT
      INTEGER
     &     I
!             LOOP VARIABLE
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     OPEN_FILE_OUT, MAKE_BLOCK_0, MAKE_BLOCK_1
     &   , MAKE_BLOCK_4, MAKE_BLOCK_8, MAKE_BLOCK_14
     &   , READ_SCHEMA_SPECTRUM
     &   , WRITE_BLOCK_0, WRITE_BLOCK_1, WRITE_BLOCK_4
     &   , WRITE_BLOCK_8, WRITE_BLOCK_14
!
!
!
!     SET THE ERROR FLAG TO AN ERROR-FREE CONDITION. THE TYPE ARRAY IS
!     INITIALIZED TO -1 TO FLAG ERRORS.
      DATA IERR/I_NORMAL/
      DATA TYPE_INDEX/NPD_GASES*-1/
!
!
!
!     OPEN THE SPECTRAL FILE
      CALL OPEN_FILE_OUT(IERR, IU_SPC
     &   , 'GIVE THE NAME OF THE SPECTRAL DATA FILE.')
      IF (IERR.NE.I_NORMAL) STOP
!
!     THE CHARACTERISTICS OF THE FILE MAY BE SET INTERACTIVELY, OR BY
!     READING A FILE OF THE CORRECT TYPE.
      WRITE(IU_USER, '(/A, /A)')
     &   'DO YOU WANT TO SPECIFY THE CHARACTERISTICS INTERACTIVELY '
     &   , 'OR READ THEM FROM A FILE? (I/F)'
      READ(IU_STDIN, '(A)') CHAR_IF
      DO WHILE ( (CHAR_IF.NE.'I').AND.(CHAR_IF.NE.'i').AND.
     &           (CHAR_IF.NE.'F').AND.(CHAR_IF.NE.'f') )
         WRITE(IU_ERR, '(A)') '+++ UNRECOGNISED INPUT:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER.'
            READ(IU_STDIN, '(A)') CHAR_IF
         ENDIF
      ENDDO
!
      IF ( (CHAR_IF.EQ.'I').OR.(CHAR_IF.EQ.'i') ) THEN
!        OBTAIN THE SUMMARY INFORMATION.
         CALL MAKE_BLOCK_0(IERR, N_BAND
     &      , N_ABSORB, TYPE_ABSORB, TYPE_INDEX
     &      , N_AEROSOL, TYPE_AEROSOL
     &      )
         IF (IERR.NE.I_NORMAL) STOP
!
!        OBTAIN THE LIMITS ON THE WAVELENGTHS.
         CALL MAKE_BLOCK_1(IERR
     &      , N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &      )
         IF (IERR.NE.I_NORMAL) STOP
!
!        SET THE TYPES OF ABSORBER IN EACH BAND
         CALL MAKE_BLOCK_4(IERR
     &      , N_BAND, N_ABSORB , TYPE_INDEX
     &      , N_BAND_ABSORB, INDEX_ABSORB
     &      )
         IF (IERR.NE.I_NORMAL) STOP
!
!        SET THE CONTINUUM TYPES.
         CALL MAKE_BLOCK_8(IERR, N_BAND, INDEX_WATER
     &      , N_BAND_CONTINUUM, INDEX_CONTINUUM
     &      )
         IF (IERR.NE.I_NORMAL) STOP
!
!        EXCLUDE BANDS IF REQUIRED.
         CALL MAKE_BLOCK_14(IERR, L_EXCLUDE, N_BAND
     &      , N_BAND_EXCLUDE, INDEX_EXCLUDE
     &      )
         IF (IERR.NE.I_NORMAL) STOP
!
!
      ELSE IF ( (CHAR_IF.EQ.'F').OR.(CHAR_IF.EQ.'f') ) THEN
         CALL READ_SCHEMA_SPECTRUM(IERR
     &      , N_BAND, N_ABSORB, TYPE_ABSORB
     &      , N_AEROSOL, TYPE_AEROSOL
     &      , WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &      , N_BAND_ABSORB, INDEX_ABSORB
     &      , N_BAND_CONTINUUM, INDEX_CONTINUUM
     &      , L_EXCLUDE, N_BAND_EXCLUDE, INDEX_EXCLUDE
     &      )
         IF (IERR.NE.I_NORMAL) STOP
      ENDIF
!
!     SET THE INDEX NUMBER OF WATER VAPOUR FOR USE WITH THE CONTINUUM.
      INDEX_WATER=0
      DO I=1, N_ABSORB
         IF (TYPE_ABSORB(I).EQ.IP_H2O) THEN
            INDEX_WATER=I
         ENDIF
      ENDDO
!
!     SETTING UP OF THE SPECTRUM IS NOW COMPLETE: WRITE ITS CONTENTS
!     AND CLOSE THE FILE.
      CALL WRITE_BLOCK_0(N_BAND, N_ABSORB, TYPE_ABSORB
     &   , N_AEROSOL, TYPE_AEROSOL
     &   )
      CALL WRITE_BLOCK_1(N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG)
      CALL WRITE_BLOCK_4(N_BAND, N_BAND_ABSORB, INDEX_ABSORB)
      CALL WRITE_BLOCK_8(N_BAND, N_BAND_CONTINUUM, INDEX_CONTINUUM
     &   , INDEX_WATER
     &   )
!     THE BLOCK OF EXCLUSIONS IS WRITTEN ONLY IF REQUIRED.
      IF (L_EXCLUDE) THEN
         CALL WRITE_BLOCK_14(N_BAND, N_BAND_EXCLUDE, INDEX_EXCLUDE)
      ENDIF
      CLOSE(IU_SPC)
!
!
!
      STOP
      END
