!+ Subroutine to make spectral blocks of type 10.
!
! Method:
!       The type of droplet is set. A fit is read from a file or
!	observational values may be used. If observational values
!	are used, a file of single scattering properties in each
!	band must be supplied for each given pressure level. The
!	pressure levels are sorted. A scaling factor may be 
!	applied to the single scattering properties.
!
! 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.
!
!- ---------------------------------------------------------------------
      SUBROUTINE 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)
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/cloud_parametrization.pcf'
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/def_sct_io.icf'
      INCLUDE 'incl/file_type.pcf'
      INCLUDE 'incl/scatter_pp.pcf'
      INCLUDE 'incl/error.pcf'
!
!     DUMMY ARGUMENTS.
      INTEGER	!, INTENT(OUT)
     &     IERR
!             ERROR FLAG
      INTEGER	!, INTENT(IN)
     &     N_BAND
!             NUMBER OF SPECTRAL BANDS
      INTEGER	!, INTENT(INOUT)
     &     I_DROP_PARAMETRIZATION(NPD_DROP_TYPE)
!             PARAMETRIZATION TYPES
     &   , N_DROP_DATA_LAYER(NPD_DROP_TYPE)
!             NUMBER OF CLOUD DATA LAYERS
      LOGICAL	!, INTENT(INOUT)
     &     L_PRESENT_10
!             PRESENCE FLAG FOR TYPE 10
     &   , L_DROP_TYPE(NPD_DROP_TYPE)
!             TYPES OF DROPS PRESENT
      REAL*8	!, INTENT(INOUT)
     &     DROP_PARAMETER_LIST(NPD_CLOUD_PARAMETER
     &   , NPD_BAND, NPD_DROP_TYPE)
!             CLOUD PARAMETERS
     &   , DROP_PRESSURE(0: NPD_CLOUD_DATA_LAYER, NPD_DROP_TYPE)
!             PRESSURE AT CLOUD DATA LEVELS
     &   , DROP_ABSORPTION(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_DROP_TYPE)
!             CLOUD ABSORPTION
     &   , DROP_SCATTERING(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_DROP_TYPE)
!             CLOUD SCATTERING
     &   , DROP_ASYMMETRY(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_DROP_TYPE)
!             CLOUD ASYMMETRY
!
!     LOCAL VARIABLES.
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
      CHARACTER
     &     CHAR_YN*1
!             CHARACTER RESPONSE VARIABLE
      INTEGER
     &     IOS
!             I/O ERROR FLAG
     &   , I_INPUT_TYPE
!             TYPE OF INPUT FILE
     &   , I_DROP
!             IDENTIFICATION NUMBER OF DROPS
     &   , N_PARAMETER
!             NUMBER OF PARAMETERS
     &   , I
!             LOOP VARIABLE
     &   , J
!             LOOP VARIABLE
     &   , K
!             LOOP VARIABLE
     &   , I_BLOCK
!             NUMBER OF DATA BLOCK
     &   , I_SCATTER_TYPE
!             TYPE OF SCATTERER
     &   , IDUM
!             DUMMY VARIABLE
     &   , POINTER(0: NPD_CLOUD_DATA_LAYER)
!             POINTER FOR SORTING
      REAL*8
     &     VOLUME_FRACTION
!             VOLUME FRACTION OF DROPLETS
     &   , RADIUS_EFF
!             EFFECTIVE RADIUS OF DROPS
     &   , NUMBER_DENSITY
!             NUMBER DENSITY OF DROPS
     &   , DUMMY(0: NPD_CLOUD_DATA_LAYER)
!             DUMMY INTERCHANGING VARIABLE
     &   , FACTOR_SCALE
!             SCALING FACTOR FOR EXTINCTION
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     SHELL_SORT
!
!
!
      WRITE(IU_USER, '(/A)') 'ENTER THE NUMBER FOR THE TYPE OF '
     &   //'DROPLETS FOR WHICH DATA ARE TO BE PROVIDED.'
1     READ(IU_STDIN, *, IOSTAT=IOS) I_DROP
      IF (IOS.NE.0) THEN
         WRITE (IU_ERR, '(A)') 'UNRECOGNIZED RESPONSE: '
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE (IU_USER, '(A)') 'PLEASE RE-ENTER.'
            GOTO 1
         ENDIF
      ENDIF
      IF ( (I_DROP.LE.0).OR.(I_DROP.GT.NPD_DROP_TYPE) ) THEN
         WRITE(IU_ERR, '(A)') '+++ RESPONSE IS OUT OF RANGE: '
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
            GOTO 1
         ENDIF
      ENDIF
!
      IF (L_DROP_TYPE(I_DROP)) THEN
         WRITE(IU_ERR, '(/A)') 'INFORMATION FOR THIS TYPE '
     &      //'OF DROP IS ALREADY PRESENT.'
         IF (.NOT.LOCK_CODE(.TRUE.)) THEN
            WRITE(IU_USER, '(A)') 'DO YOU WISH TO OVERWRITE? (Y/N)'
2           READ(IU_STDIN, '(A)') CHAR_YN
            IF ( (CHAR_YN.EQ.'N').OR.(CHAR_YN.EQ.'n') ) THEN
               WRITE(IU_USER, '(A)') 'ENTER A NEW NUMBER.'
               RETURN
            ELSE IF ( (CHAR_YN.NE.'Y').AND.(CHAR_YN.NE.'y') ) THEN
               WRITE(IU_ERR, '(A)') '+++ UNRECOGNIZED RESPONSE: '
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 2
            ENDIF
         ENDIF
      ENDIF
!
      WRITE(IU_USER, '(/A)') 'USE DIRECT OBSERVATIONAL DATA? (Y/N)'
3     READ(IU_STDIN, '(A)') CHAR_YN
      IF ( (CHAR_YN.EQ.'Y').OR.(CHAR_YN.EQ.'y') ) THEN
         J=0
4        CALL OPEN_FILE_IN(IERR, IU_AVERAGE
     &      , 'ENTER NAME OF FILE OF AVERAGED MIE '
     &      //'DATA AT A CLOUD LEVEL.')
         IF (IERR.NE.I_NORMAL) THEN
            IERR=I_ABORT_CALCULATION
            RETURN
         ENDIF
         READ(IU_AVERAGE, '(13X, I5)') I_INPUT_TYPE
         IF (I_INPUT_TYPE.NE.IT_FILE_AVE_MIE_DRY) THEN
            WRITE(IU_ERR, '(A)') '+++ INVALID TYPE OF FILE: '
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               GOTO 4
            ENDIF
         ENDIF
         READ(IU_AVERAGE, '(///, 11X, I5, /, 23X, I5)')
     &      I_BLOCK, I_SCATTER_TYPE
         IF (I_SCATTER_TYPE.NE.IP_TYPE_DROPLET) THEN
            WRITE(IU_ERR, '(A)') '+++ INVALID TYPE OF SCATTERER: '
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               GOTO 4
            ENDIF
         ENDIF
         READ(IU_AVERAGE, '(/, 3(22X, 1PE12.5, /), //)')
     &        NUMBER_DENSITY, RADIUS_EFF, VOLUME_FRACTION
         DO I=1, N_BAND
            READ(IU_AVERAGE, '(I5, 3(4X, 1PE12.5, 4X))')
     &           IDUM, DROP_ABSORPTION(J, I, I_DROP)
     &         , DROP_SCATTERING(J, I, I_DROP)
     &         , DROP_ASYMMETRY(J, I, I_DROP)
         ENDDO
         READ(IU_AVERAGE, '(//)')
         CLOSE(IU_AVERAGE)
!
         WRITE(IU_USER, '(A)') 'ENTER THE PRESSURE TO WHICH THESE '
     &      //'PROPERTIES REFER.'
5        READ(IU_STDIN, *, IOSTAT=IOS) DROP_PRESSURE(J, I_DROP)
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)')
     &         '+++ UNRECOGNIZED RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 5
            ENDIF
         ENDIF
!
         WRITE(IU_USER, '(A)') 'ENTER THE SCALING FACTOR FOR THE '
     &      //'EXTINCTION.'
7        READ(IU_STDIN, *, IOSTAT=IOS) FACTOR_SCALE
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ UNRECOGNIZED RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 7
            ENDIF
         ENDIF
         DO I=1, N_BAND
            DROP_ABSORPTION(J, I, I_DROP)=FACTOR_SCALE
     &         *DROP_ABSORPTION(J, I, I_DROP)
            DROP_SCATTERING(J, I, I_DROP)=FACTOR_SCALE
     &         *DROP_SCATTERING(J, I, I_DROP)
         ENDDO
!
         WRITE(IU_USER, '(A)') 'ADD ANOTHER PRESSURE LEVEL? (Y/N)'
6        READ(IU_STDIN, '(A)') CHAR_YN
         IF ( (CHAR_YN.EQ.'Y').OR.(CHAR_YN.EQ.'y') ) THEN
            J=J+1
            GOTO 4
         ELSE IF ( (CHAR_YN.NE.'N').AND.(CHAR_YN.NE.'n') ) THEN
            WRITE(IU_ERR, '(/A)') '+++ ILLEGAL RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               WRITE(IU_USER, '(/A)') 'PLEASE REENTER.'
               GOTO 6
            ENDIF
         ENDIF
!
!        CHECK THAT THE DATA ARE SUFFICIENT.
         IF (J.LT.1) THEN
            WRITE(IU_ERR, '(A)') '+++ TO FEW CLOUD LEVELS HAVE BEEN '
     &         //'SPECIFIED.'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE GIVE ANOTHER LEVEL.'
               GOTO 4
            ENDIF
         ELSE
            N_DROP_DATA_LAYER(I_DROP)=J
!           ORDER THE DATA BY INCREASING PRESSURE.
!           SET UP THE POINTER FOR SORTING BEGINNING AT 1.
            DO J=0, N_DROP_DATA_LAYER(I_DROP)
               POINTER(J)=J+1
            ENDDO
            J=N_DROP_DATA_LAYER(I_DROP)+1
            CALL SHELL_SORT(J, POINTER(0), DROP_PRESSURE(0, I_DROP) )
            DO J=0, N_DROP_DATA_LAYER(I_DROP)
               DUMMY(J)=DROP_PRESSURE(POINTER(J)-1, I_DROP)
            ENDDO
            DO J=0, N_DROP_DATA_LAYER(I_DROP)
               DROP_PRESSURE(J, I_DROP)=DUMMY(J)
            ENDDO
            DO I=1, N_BAND
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DUMMY(J)=DROP_ABSORPTION(POINTER(J)-1, I, I_DROP)
               ENDDO
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DROP_ABSORPTION(J, I, I_DROP)=DUMMY(J)
               ENDDO
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DUMMY(J)=DROP_SCATTERING(POINTER(J)-1, I, I_DROP)
               ENDDO
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DROP_SCATTERING(J, I, I_DROP)=DUMMY(J)
               ENDDO
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DUMMY(J)=DROP_ASYMMETRY(POINTER(J)-1, I, I_DROP)
               ENDDO
               DO J=0, N_DROP_DATA_LAYER(I_DROP)
                  DROP_ASYMMETRY(J, I, I_DROP)=DUMMY(J)
               ENDDO
            ENDDO
         ENDIF
!
         I_DROP_PARAMETRIZATION(I_DROP)=IP_DROP_UNPARAMETRIZED
!
      ELSE IF ( (CHAR_YN.EQ.'N').OR.(CHAR_YN.EQ.'n') ) THEN
!
!        OPEN THE FILE OF INPUT DATA.
8        CALL OPEN_FILE_IN(IERR, IU_CLOUD_FIT
     &      , 'ENTER THE NAME OF THE FILE CONTAINING THE FITTED '
     &      //'PARAMETERS FOR DROPLETS.')
         IF (IERR.NE.I_NORMAL) RETURN
!
         READ(IU_CLOUD_FIT, '(13X, I5)') I_INPUT_TYPE
         IF (I_INPUT_TYPE.NE.IT_FILE_CLOUD_FIT) THEN
            WRITE(IU_ERR, '(A)') '+++ INVALID TYPE OF FILE: '
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               GOTO 8
            ENDIF
         ENDIF
         READ(IU_CLOUD_FIT, '(///, 33X, I5, /, 31X, I5)', IOSTAT=IOS)
     &      I_DROP_PARAMETRIZATION(I_DROP), N_PARAMETER
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(/A)')
     &         '*** ERROR: ERROR IN FORMAT OF INPUT DATA.'
            IERR=I_ERR_FATAL
            RETURN
         ENDIF
         DO I=1, N_BAND
            READ(IU_CLOUD_FIT, '(/, 4(4X, 1PE12.5))', IOSTAT=IOS)
     &         (DROP_PARAMETER_LIST(K, I, I_DROP)
     &         , K=1, N_PARAMETER)
            IF (IOS.NE.0) THEN
               WRITE(IU_ERR, '(/A)')
     &            '*** ERROR: ERROR IN FORMAT OF INPUT DATA.'
            ENDIF
         ENDDO
         READ(IU_CLOUD_FIT, '(//)')
!
         CLOSE(IU_CLOUD_FIT)
!
      ELSE
         WRITE(IU_ERR, '(A)') '+++ UNRECOGNIZED RESPONSE:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER'
            GOTO 3
         ENDIF
      ENDIF
      L_DROP_TYPE(I_DROP)=.TRUE.
!
!     SET THE PRESENCE FLAG FOR THE DATA.
      L_PRESENT_10=.FALSE.
      DO I=1, NPD_DROP_TYPE
         L_PRESENT_10=L_PRESENT_10.OR.L_DROP_TYPE(I)
      ENDDO
!
!
      RETURN
      END
