!+ Subroutine to make spectral blocks of type 12.
!
! Method:
!       The type of ice crystal 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_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)
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/ice_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_ICE_PARAMETRIZATION(NPD_ICE_TYPE)
!             PARAMETRIZATION TYPES
     &   , N_ICE_DATA_LAYER(NPD_ICE_TYPE)
!             NUMBER OF ICE CLOUD DATA LAYERS
      LOGICAL	!, INTENT(INOUT)
     &     L_PRESENT_12
!             PRESENCE FLAG FOR TYPE 12
     &   , L_ICE_TYPE(NPD_ICE_TYPE)
!             TYPES OF ICE CRYSTALS PRESENT
      REAL*8	!, INTENT(INOUT)
     &     ICE_PARAMETER_LIST(NPD_CLOUD_PARAMETER
     &   , NPD_BAND, NPD_ICE_TYPE)
!             ICE CLOUD PARAMETERS
     &   , ICE_PRESSURE(0: NPD_CLOUD_DATA_LAYER, NPD_ICE_TYPE)
!             PRESSURE AT ICE CLOUD DATA LEVELS
     &   , ICE_ABSORPTION(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_ICE_TYPE)
!             ICE CLOUD ABSORPTION
     &   , ICE_SCATTERING(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_ICE_TYPE)
!             ICE CLOUD SCATTERING
     &   , ICE_ASYMMETRY(0: NPD_CLOUD_DATA_LAYER, NPD_BAND
     &        , NPD_ICE_TYPE)
!             ICE 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_ICE
!             IDENTIFICATION NUMBER OF CRYSTALS
     &   , 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 CRYSTALS
     &   , RADIUS_EFF
!             EFFECTIVE RADIUS OF CRYSTALS
     &   , NUMBER_DENSITY
!             NUMBER DENSITY OF ICE CRYSTALS
     &   , DUMMY(0: NPD_CLOUD_DATA_LAYER)
!             DUMMY INTERCHANGING VARIABLE
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     SHELL_SORT
!
!
!
      WRITE(IU_USER, '(/A)') 'ENTER THE NUMBER FOR THE TYPE OF '
     &   //'ICE CRYSTALS FOR WHICH DATA ARE TO BE PROVIDED.'
1     READ(IU_STDIN, *, IOSTAT=IOS) I_ICE
      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_ICE.LE.0).OR.(I_ICE.GT.NPD_ICE_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_ICE_TYPE(I_ICE)) THEN
         WRITE(IU_USER, '(/A)') 'INFORMATION FOR THIS TYPE '
     &      //'OF ICE CRYSTAL IS ALREADY PRESENT.'
         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: '
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error.finc'
            ELSE
               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 SCATTERING '
     &      //'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)') '+++ THIS FILE IS OF AN INVALID TYPE.'
            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_ICE) THEN
            WRITE(IU_ERR, '(A)') '+++ THE SCATTERER IS NOT ICE.'
            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, ICE_ABSORPTION(J, I, I_ICE)
     &         , ICE_SCATTERING(J, I, I_ICE)
     &         , ICE_ASYMMETRY(J, I, I_ICE)
         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) ICE_PRESSURE(J, I_ICE)
         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)') '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
            IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
            ELSE
            WRITE(IU_ERR, '(A)') '+++ TO FEW CLOUD LEVELS HAVE BEEN '
     &         //'SPECIFIED.'
            WRITE(IU_USER, '(A)') 'PLEASE GIVE ANOTHER LEVEL.'
            GOTO 4
            ENDIF
         ELSE
            N_ICE_DATA_LAYER(I_ICE)=J
!           ORDER THE DATA BY INCREASING PRESSURE.
!           SET UP THE POINTER FOR SORTING BEGINNING AT 1.
            DO J=0, N_ICE_DATA_LAYER(I_ICE)
               POINTER(J)=J+1
            ENDDO
            J=N_ICE_DATA_LAYER(I_ICE)+1
            CALL SHELL_SORT(J, POINTER(0)
     &         , ICE_PRESSURE(0, I_ICE) )
            DO J=0, N_ICE_DATA_LAYER(I_ICE)
               DUMMY(J)=ICE_PRESSURE(POINTER(J)-1, I_ICE)
            ENDDO
            DO J=0, N_ICE_DATA_LAYER(I_ICE)
               ICE_PRESSURE(J, I_ICE)=DUMMY(J)
            ENDDO
            DO I=1, N_BAND
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  DUMMY(J)=ICE_ABSORPTION(POINTER(J)-1, I, I_ICE)
               ENDDO
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  ICE_ABSORPTION(J, I, I_ICE)=DUMMY(J)
               ENDDO
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  DUMMY(J)=ICE_SCATTERING(POINTER(J)-1, I, I_ICE)
               ENDDO
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  ICE_SCATTERING(J, I, I_ICE)=DUMMY(J)
               ENDDO
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  DUMMY(J)=ICE_ASYMMETRY(POINTER(J)-1, I, I_ICE)
               ENDDO
               DO J=0, N_ICE_DATA_LAYER(I_ICE)
                  ICE_ASYMMETRY(J, I, I_ICE)=DUMMY(J)
               ENDDO
            ENDDO
         ENDIF
!
         I_ICE_PARAMETRIZATION(I_ICE)=IP_ICE_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 ICE CRYSTALS.')
         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)') '+++ THIS FILE IS OF AN INVALID TYPE.'
            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_ICE_PARAMETRIZATION(I_ICE), N_PARAMETER
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(/A)')
     &         '***ERROR: ERROR IN FORMAT OF INPUT DATA.'
         ENDIF
         DO I=1, N_BAND
            READ(IU_CLOUD_FIT, '(/, 4(4X, 1PE12.5))', IOSTAT=IOS)
     &         (ICE_PARAMETER_LIST(K, I, I_ICE)
     &         , 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_ICE_TYPE(I_ICE)=.TRUE.
!
!     SET THE PRESENCE FLAG FOR THE DATA.
      L_PRESENT_12=.FALSE.
      DO I=1, NPD_ICE_TYPE
         L_PRESENT_12=L_PRESENT_12.OR.L_ICE_TYPE(I)
      ENDDO
!
!
      RETURN
      END
