!+ Subroutine to make spectral blocks of type 6.
!
! Method:
!	A range of temperatures and the degree of the fitting 
!	polynomial are determined. Using SVD, a least squares fit
!	to the Planck function in each band over this range of 
!	temperatures is madde to determine the coefficients.
!
! 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_6(IERR
     &   , N_BAND, WAVE_LENGTH_SHORT, WAVE_LENGTH_LONG
     &   , L_EXCLUDE, N_BAND_EXCLUDE, INDEX_EXCLUDE
     &   , N_DEG_FIT, T_REF_THERMAL, THERMAL_COEFFICIENT
     &   , L_PRESENT_6
     &   )
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/dimensions_spec.ucf'
      INCLUDE 'incl/dimensions_pp.ucf'
      INCLUDE 'incl/prec_machine.ucf'
      INCLUDE 'incl/precision_pp.tcf'
      INCLUDE 'incl/math_cnst.ccf'
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/physical_constants_pp.ccf'
      INCLUDE 'incl/thermal_pp.tcf'
      INCLUDE 'incl/error.pcf'
!
!     DUMMY ARGUMENTS.
      INTEGER	!, INTENT(OUT)
     &     IERR
!             ERROR FLAG
     &   , N_DEG_FIT
!             NUMBER OF TERMS IN FIT
      LOGICAL	!, INTENT(IN)
     &     L_EXCLUDE
!             FLAG FOR EXCLUSION OF SPECIFIC BANDS
      INTEGER	!, INTENT(IN)
     &     N_BAND
!             NUMBER OF SPECTRAL BANDS
     &   , N_BAND_EXCLUDE(NPD_BAND)
!             NUMBER OF BANDS EXCLUDED FROM A SPECIFIC REGION
     &   , INDEX_EXCLUDE(NPD_EXCLUDE, NPD_BAND)
!             INDICES OF EXCLUDED BANDS
      LOGICAL	!, INTENT(OUT)
     &     L_PRESENT_6
!             PRESENCE FLAG FOR BLOCK
      REAL*8	!, INTENT(IN)
     &     WAVE_LENGTH_SHORT(NPD_BAND)
!             SHORTER WAVELENGTHS OF BANDS
     &   , WAVE_LENGTH_LONG(NPD_BAND)
!             LONGER WAVELENGTHS OF BANDS
      REAL*8	!, INTENT(OUT)
     &     T_REF_THERMAL
!             PLANCKIAN REFERENCE TEMP
     &   , THERMAL_COEFFICIENT(0: NPD_THERMAL_COEFF-1, NPD_BAND)
!             COEFFICIENTS FOR FITS
!
!     LOCAL VARIABLES.
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
      INTEGER
     &     IOS
!             I/O ERROR FLAG
     &   , I
!             LOOP VARIABLE
     &   , J
!             LOOP VARIABLE
     &   , K
!             LOOP VARIABLE
     &   , N_COEFFICIENT
!             NUMBER OF COEFFICIENTS
     &   , I_EXCLUDE
!             NUMBER OF EXCLUDED BAND
      REAL*8
     &     T_FIT_LOW
!             LOWEST FITTED TEMPERATURE
     &   , T_FIT_HIGH
!             LOWEST FITTED TEMPERATURE
     &   , T_TEMP
!             TEMPORARY TEMPERATURE
     &   , ALPHA
!             NUMERICAL CONSTANT
     &   , Q
!             NUMERICAL CONSTANT
     &   , A(0: NPD_THERMAL_COEFF-1, 0: NPD_THERMAL_COEFF-1)
!             LEAST SQUARES COEFFICIENT MATRIX
     &   , B(0: NPD_THERMAL_COEFF-1)
!             LEAST SQUARES FORCING TERM
     &   , A_EXCLUDE(0: NPD_THERMAL_COEFF-1, 0: NPD_THERMAL_COEFF-1)
!             LEAST SQUARES COEFFICIENT MATRIX FOR EXCLUDED BANDS
     &   , B_EXCLUDE(0: NPD_THERMAL_COEFF-1)
!             LEAST SQUARES FORCING TERM FOR EXCLUDED BANDS
     &   , W(0: NPD_THERMAL_COEFF-1)
!             DIAGONAL OF SVD DECOMPOSITION
     &   , V(0: NPD_THERMAL_COEFF-1, 0: NPD_THERMAL_COEFF-1)
!             LEAST SQUARES COEFFICIENT MATRIX
     &   , WRK(0: NPD_THERMAL_COEFF-1)
!             WORK ARRAY
     &   , WMAX
!             MAXIMUM DIAGONAL ELEMENT
     &   , THRESHOLD
!             THRESHOLD FOR ZEROING
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     CALC_THERMAL_COEFF, SVD_DECOMPOSE, BACK_SUBSTITUTE
!
!
!
!     OBTAIN LIMITS OVER WHICH FIT IS REQUIRED.
      WRITE(IU_USER, '(/A)') 'ENTER THE RANGE OF TEMPERATURES OVER '
     &   //'WHICH THE FIT IS REQUIRED.'
1     READ(IU_STDIN, *, IOSTAT=IOS) T_FIT_LOW, T_FIT_HIGH
      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 (T_FIT_LOW.GT.T_FIT_HIGH) THEN
         T_TEMP=T_FIT_LOW
         T_FIT_LOW=T_FIT_HIGH
         T_FIT_HIGH=T_TEMP
      ENDIF
      IF (T_FIT_LOW.LT.0.0D+00) THEN
         WRITE(IU_ERR, '(A)') '+++ ILLEGAL RESPONSE:'
         WRITE(IU_ERR, '(A)') 'A NEGATIVE ABSOLUTE TEMPERATURE WAS '
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-SPECIFY.'
            GOTO 1
         ENDIF
      ENDIF
      IF (T_FIT_LOW.GT.(T_FIT_HIGH-P_MIN_THERMAL_RANGE)) THEN
         WRITE(IU_ERR, '(A)')
     &      '+++ RANGE OF TEMPERATURES IS TOO SMALL:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER.'
            GOTO 1
         ENDIF
      ENDIF
!
!     THE REFERENCE TEMPERATURE CAN CONVENIENTLY BE TAKEN AS THE
!     HARMONIC MEAN TEMPERATURE OF THE RANGE.
      T_REF_THERMAL=SQRT(T_FIT_LOW*T_FIT_HIGH)
!
      WRITE(IU_USER, '(/A)')
     &   'ENTER THE DEGREE OF THE FITTING POLYNOMIAL.'
2     READ(IU_STDIN, *, IOSTAT=IOS) N_DEG_FIT
      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 2
         ENDIF
      ENDIF
      IF (N_DEG_FIT.LT.0) THEN
         WRITE(IU_ERR, '(A)') 'A NEGATIVE DEGREE IS UNACCEPTABLE: '
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RESPECIFY.'
            GOTO 2
         ENDIF
      ENDIF
      IF (N_DEG_FIT.GT.NPD_THERMAL_COEFF-1) THEN
         WRITE(IU_ERR, '(A)') 'THIS DEGREE IS TOO HIGH: '
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RESPECIFY.'
            GOTO 2
         ENDIF
      ENDIF
      N_COEFFICIENT=N_DEG_FIT+1
!
!     SCALE THE TEMPERATURES.
      T_FIT_LOW=T_FIT_LOW/T_REF_THERMAL
      T_FIT_HIGH=T_FIT_HIGH/T_REF_THERMAL
      ALPHA=K_BOLTZMANN*T_REF_THERMAL/(H_PLANCK*C_LIGHT)
      Q=2.0D+00*PI*H_PLANCK*ALPHA**4*C_LIGHT**2
!
!     FOR EACH BAND A LEAST SQUARES FIT IN THE SCALED TEMPERATURE IS
!     PERFORMED.
      DO I=1, N_BAND
         CALL CALC_THERMAL_COEFF(IERR
     &      , N_DEG_FIT
     &      , WAVE_LENGTH_SHORT(I), WAVE_LENGTH_LONG(I)
     &      , T_FIT_LOW, T_FIT_HIGH
     &      , ALPHA, Q
     &      , A, B)
         IF (IERR.NE.I_NORMAL) RETURN
!
!        IF REGIONS OF THE BAND ARE EXCLUDED, THE CORRESPONDING REGIONS
!        MUST BE REMOVED FROM B.
         IF (L_EXCLUDE) THEN
            DO J=1, N_BAND_EXCLUDE(I)
               I_EXCLUDE=INDEX_EXCLUDE(J, I)
               CALL CALC_THERMAL_COEFF(IERR
     &            , N_DEG_FIT
     &            , WAVE_LENGTH_SHORT(I_EXCLUDE)
     &            , WAVE_LENGTH_LONG(I_EXCLUDE)
     &            , T_FIT_LOW, T_FIT_HIGH
     &            , ALPHA, Q
     &            , A_EXCLUDE, B_EXCLUDE)
               IF (IERR.NE.I_NORMAL) RETURN
               DO K=0, N_DEG_FIT
                  B(K)=B(K)-B_EXCLUDE(K)
               ENDDO
            ENDDO
         ENDIF
!        PERFORM AN SVD DECOMPOSITION OF THE MATRIX.
         CALL SVD_DECOMPOSE(IERR
     &      , A, N_COEFFICIENT, N_COEFFICIENT
     &      , NPD_THERMAL_COEFF, NPD_THERMAL_COEFF
     &      , W, V, WRK
     &      )
         IF (IERR.NE.I_NORMAL) RETURN
!
!        ZERO VERY SMALL TERMS OF THE DIAGONAL MATRIX.
         WMAX=0.0D+00
         DO J=0, N_DEG_FIT
            IF (W(J).GT.WMAX) THEN
               WMAX=W(J)
            ENDIF
         ENDDO
         THRESHOLD=TOL_CONDITION*WMAX
         DO J=0, N_DEG_FIT
            IF (W(J).LT.THRESHOLD) THEN
               W(J)=0.0D+00
            ENDIF
         ENDDO
!
!        SOLVE THE EQUATIONS BY BACK-SUBSTITUTION.
         CALL BACK_SUBSTITUTE(A, W, V
     &      , N_COEFFICIENT, N_COEFFICIENT
     &      , NPD_THERMAL_COEFF, NPD_THERMAL_COEFF
     &      , B, THERMAL_COEFFICIENT(0, I), WRK
     &      )
!
      ENDDO
!
!     THE DATA ARE NOW CORRECTLY ASSEMBLED SO THE PRESENCE FLAG IS SET.
      L_PRESENT_6=.TRUE.
!
!
      RETURN
      END
