C ###############################################################
C #                                                             #
C #                    THE VLIDORT  MODEL                       #
C #                                                             #
C #  Vectorized LInearized Discrete Ordinate Radiative Transfer #
C #  -          --         -        -        -         -        #
C #                                                             #
C ###############################################################

C ###############################################################
C #                                                             #
C #  Author :      Robert. J. D. Spurr                          #
C #                                                             #
C #  Address :      RT Solutions, Inc.                          #
C #            9 Channing Street                                #
C #             Cambridge, MA 02138, USA                        #
C #            Tel: (617) 492 1183                              #
C #                                                             #
C #  Email :      rtsolutions@verizon.net                       #
C #                                                             #
C #  Versions     :   2.0, 2.2, 2.3, 2.4, 2.4R, 2.4RT           #
C #  Release Date :   December 2005  (2.0)                      #
C #  Release Date :   March 2007     (2.2)                      #
C #  Release Date :   October 2007   (2.3)                      #
C #  Release Date :   December 2008  (2.4)                      #
C #  Release Date :   April/May 2009 (2.4R)                     #
C #  Release Date :   July 2009      (2.4RT)                    #
C #                                                             #
C #       NEW: TOTAL COLUMN JACOBIANS         (2.4)             #
C #       NEW: BPDF Land-surface KERNELS      (2.4R)            #
C #       NEW: Thermal Emission Treatment     (2.4RT)           #
C #                                                             #
C ###############################################################

C    #####################################################
C    #                                                   #
C    #   This Version of VLIDORT comes with a GNU-style  #
C    #   license. Please read the license carefully.     #
C    #                                                   #
C    #####################################################

C ###############################################################
C #                                                             #
C # Subroutines in this Module                                  #
C #                                                             #
C #            VLIDORT_L_MASTER_LAMBERTIAN (master)             #
C #            VLIDORT_L_FOURIER_LAMBERTIAN (master)            #
C #                                                             #
C ###############################################################

      SUBROUTINE VLIDORT_L_MASTER_LAMBERTIAN
     &     ( STATUS_INPUTCHECK, STATUS_CALCULATION )

C  Standard model include files
C  ----------------------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  Include file of linearization input variables

      INCLUDE '../includes/VLIDORT_L_INPUTS.VARS'

C  subroutine arguments
C  --------------------

      INTEGER          STATUS_INPUTCHECK
      INTEGER          STATUS_CALCULATION

C  local variables
C  ---------------

      LOGICAL          LOCAL_DO_NO_AZIMUTH
      LOGICAL          SAVE_DO_NO_AZIMUTH
      LOGICAL          LOCAL_ITERATION
      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_SURFEMISS
      LOGICAL          DO_INCLUDE_THERMEMISS

      INTEGER          FOURIER_COMPONENT
      INTEGER          N_FOURIER_COMPONENTS

      INTEGER          UM, UA, TESTCONV, L
      INTEGER          LOCAL_N_USERAZM, STATUS_SUB
      INTEGER          IUNIT, SUNIT, FUNIT, RUNIT

      DOUBLE PRECISION AZM_ARGUMENT, DFC
      DOUBLE PRECISION AZMFAC
     &     (MAX_USER_STREAMS,MAXBEAMS,MAX_USER_RELAZMS,MAXSTOKES)

      INTEGER          IBEAM_COUNT, IBEAM, IB, NSOURCES
      LOGICAL          BEAM_ITERATION ( MAXBEAMS )
      INTEGER          BEAM_TESTCONV  ( MAXBEAMS )

      LOGICAL          ADJUST_SURFACE

      DOUBLE PRECISION SS_FLUX_MULTIPLIER, modified_eradius

C  Local error handling

      LOGICAL          FAIL
      CHARACTER*70     MAIL, TRACE
      CHARACTER*3      CF

C  initialize output status
C  ------------------------

      STATUS_CALCULATION = VLIDORT_SUCCESS
      STATUS_INPUTCHECK  = VLIDORT_SUCCESS

C  set multiplier

      SS_FLUX_MULTIPLIER = FLUX_FACTOR / PI4

C  Check input
C  -----------

C  Standard input variables check

      CALL VLIDORT_CHECK_INPUT ( STATUS_SUB )

      IF ( STATUS_SUB .EQ. VLIDORT_SERIOUS ) THEN
        STATUS_INPUTCHECK = VLIDORT_SERIOUS
        MAIL = ' VLIDORT_CHECK_INPUT failed'
        TRACE = ' Called in VLIDORT_L_MASTER '
        CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_INPUTCHECK )
        CLOSE(VLIDORT_ERRUNIT)
        RETURN
      ELSE IF ( STATUS_SUB .EQ. VLIDORT_WARNING ) THEN
        STATUS_INPUTCHECK = VLIDORT_WARNING
        MAIL = ' VLIDORT_CHECK_INPUT warning message'
        TRACE = ' Called in VLIDORT_L_MASTER '
        CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_INPUTCHECK )
      ENDIF

C  Extended input variables check

      IF ( DO_LINEARIZATION ) THEN

        CALL VLIDORT_L_CHECK_INPUT ( STATUS_SUB )

        IF ( STATUS_SUB .EQ. VLIDORT_SERIOUS ) THEN
          STATUS_INPUTCHECK = VLIDORT_SERIOUS
          MAIL = ' VLIDORT_L_CHECK_INPUT failed'
          TRACE = ' Called in VLIDORT_L_MASTER_LAMBERTIAN'
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_INPUTCHECK )
          CLOSE(VLIDORT_ERRUNIT)
          RETURN
        ELSE IF ( STATUS_SUB .EQ. VLIDORT_WARNING ) THEN
          STATUS_INPUTCHECK = VLIDORT_WARNING
          MAIL = ' VLIDORT_L_CHECK_INPUT warning message'
          TRACE = ' Called in VLIDORT_L_MASTER_LAMBERTIAN'
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_INPUTCHECK )
        ENDIF

      ENDIF

C  Geometry adjustment
C  -------------------

C  Adjust surface condition

      ADJUST_SURFACE = .FALSE.
      IF ( DO_SSCORR_OUTGOING ) THEN
        IF (HEIGHT_GRID(NLAYERS).GT.GEOMETRY_SPECHEIGHT ) THEN
         ADJUST_SURFACE = .TRUE.
        ENDIF
      ENDIF

C  Perform adjustment

      modified_eradius = earth_radius + geometry_specheight
      CALL multi_outgoing_adjustgeom
     i   ( MAX_USER_VZANGLES, MAX_SZANGLES, MAX_USER_RELAZMS,
     i     N_USER_VZANGLES,   N_SZANGLES,   N_USER_RELAZMS,
     i     height_grid(nlayers), modified_eradius, adjust_surface,
     i     user_vzangles,  szangles, user_relazms,
     o     user_vzangles_adjust, szangles_adjust, user_relazms_adjust,
     o     fail, mail )
      if ( fail ) return

C  Chapman function calculation
C  ----------------------------

      IF ( DO_CHAPMAN_FUNCTION ) THEN
        CALL VLIDORT_CHAPMAN ( FAIL, MAIL, TRACE )
        IF (FAIL) THEN
          STATUS_CALCULATION = VLIDORT_SERIOUS
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_CALCULATION )
          CLOSE(VLIDORT_ERRUNIT)
          RETURN
        ENDIF
      ENDIF

C  write input variables
C  ---------------------

C  open file, call standard/linearized input writes, close file

      IF ( DO_WRITE_INPUT ) THEN
        IUNIT = VLIDORT_INUNIT
        OPEN(IUNIT,FILE=INPUT_WRITE_FILENAME,STATUS='UNKNOWN')
        CALL VLIDORT_WRITEINPUT ( IUNIT )
        IF ( DO_LINEARIZATION ) THEN
          CALL VLIDORT_L_WRITEINPUT ( IUNIT )
        ENDIF
        CLOSE(IUNIT)
      ENDIF

C  Get derived inputs
C  ==================

C  Miscellaneous and layer input.

      CALL VLIDORT_DERIVE_INPUT ( STATUS_SUB, MAIL )

      IF ( STATUS_SUB .EQ. VLIDORT_WARNING ) THEN
        STATUS_INPUTCHECK = VLIDORT_WARNING
        TRACE = 'Derive_Input Call in VLIDORT_L_MASTERS_LAMBERTIAN'
        CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_INPUTCHECK )
      ENDIF

C  Derive number of Surface weighting functions
C  Automatically 1 in this version without the BRDFs

      N_TOTALBRDF_WFS = 1

c      IF ( .NOT. DO_LAMBERTIAN_SURFACE ) THEN
c       COUNT = 0
c       DO KL = 1, N_BRDF_KERNELS
c        IF ( DO_KERNEL_FACTOR_WFS(KL) ) COUNT = COUNT + 1
c        DO_KPARAMS_DERIVS(KL) = .FALSE.
c        DO KQ = 1, N_BRDF_PARAMETERS(KL)
c          IF ( DO_KERNEL_PARAMS_WFS(KL,KQ) ) THEN
c            COUNT = COUNT + 1
c            DO_KPARAMS_DERIVS(KL) = .TRUE.
c          ENDIF
c        ENDDO
c       ENDDO
c      ENDIF
C      N_TOTALBRDF_WFS = COUNT

C  standard + linearized BRDF inputs, both together

c      IF ( .NOT. DO_LAMBERTIAN_SURFACE ) THEN
c        CALL VLIDORT_L_BRDF_CREATOR
c      ENDIF

C  Initialise Fourier loop
C  =======================

C  Single scatter correction: flux multiplier

      IF ( DO_SSCORR_NADIR .OR. DO_SSCORR_OUTGOING ) THEN
        SS_FLUX_MULTIPLIER = FLUX_FACTOR / PI4
      ELSE
        SS_FLUX_MULTIPLIER = FLUX_FACTOR / PI4
      ENDIF

C  Set Number of Fourier terms (NMOMENTS = Maximum).
C    ( Starting from 0 = Fundamental )

      SAVE_DO_NO_AZIMUTH  = DO_NO_AZIMUTH
      LOCAL_DO_NO_AZIMUTH = DO_NO_AZIMUTH

C  No azimuth dependency for following cases
C   Other cases now disabled, 17 Janaury 2006

C      IF ( DO_TRANSMITTANCE_ONLY ) THEN
C        LOCAL_DO_NO_AZIMUTH = .TRUE.
C      ENDIF

c      IF ( DO_ISOTROPIC_ONLY  ) THEN
c        LOCAL_DO_NO_AZIMUTH = .TRUE.
c      ENDIF

      IF ( .NOT. DO_SOLAR_SOURCES  ) THEN
        LOCAL_DO_NO_AZIMUTH = .TRUE.
      ENDIF

      IF ( DO_MVOUT_ONLY  ) THEN
        LOCAL_DO_NO_AZIMUTH = .TRUE.
      ENDIF

C  set Fourier number (2 for Rayleigh only)

      IF ( LOCAL_DO_NO_AZIMUTH .OR. DO_SSFULL ) THEN
        N_FOURIER_COMPONENTS = 0
      ELSE
        IF ( DO_RAYLEIGH_ONLY  ) THEN
          N_FOURIER_COMPONENTS = 2
        ELSE
          N_FOURIER_COMPONENTS = NMOMENTS
        ENDIF
      ENDIF

C  re-set no-azimuth flag

      DO_NO_AZIMUTH = LOCAL_DO_NO_AZIMUTH

C  if there's no azimuth dependence, just do one value in azimuth loop

      IF ( DO_NO_AZIMUTH ) THEN
        LOCAL_N_USERAZM = 1
       ELSE
        LOCAL_N_USERAZM = N_USER_RELAZMS
      ENDIF

C  Number of sources

      IF ( DO_SOLAR_SOURCES ) THEN
        NSOURCES = NBEAMS
      ELSE
        NSOURCES = 1
        NBEAMS   = 1
      ENDIF

C  save some offsets for indexing geometries
C     These results are now stored in VLIDORT_BOOKKEEP.VARS

      N_VIEWING    = N_USER_VZANGLES * LOCAL_N_USERAZM
      N_GEOMETRIES = NSOURCES * N_VIEWING
      DO IBEAM = 1, NBEAMS
        SZA_OFFSETS(IBEAM) = N_VIEWING * ( IBEAM - 1 )
        DO UM = 1, N_USER_VZANGLES
          VZA_OFFSETS(IBEAM,UM) =
     &           SZA_OFFSETS(IBEAM) + LOCAL_N_USERAZM * (UM - 1)
        END DO
      END DO

C  Fourier loop
C  ============

C  Initialize

      LOCAL_ITERATION   = .TRUE.
      FOURIER_COMPONENT = -1
      TESTCONV          = 0

C  set up solar beam flags

      DO IBEAM = 1, NBEAMS
        BEAM_TESTCONV  ( IBEAM )  = 0
        BEAM_ITERATION ( IBEAM ) = .TRUE.
        DO L = 0, MAXFOURIER
          DO_MULTIBEAM   ( IBEAM, L ) = .TRUE.
        ENDDO
      ENDDO

C  start loop

      DO WHILE ( LOCAL_ITERATION .AND.
     &             FOURIER_COMPONENT.LT.N_FOURIER_COMPONENTS )

C  Fourier counter

        FOURIER_COMPONENT = FOURIER_COMPONENT + 1

C  Local start of user-defined streams. Should always be 1.
C    No zenith tolerance now.

        LOCAL_UM_START = 1

C  azimuth cosine/sine factors, using adjust geometries.

        IF ( FOURIER_COMPONENT .GT. 0 ) THEN
          DFC = DBLE(FOURIER_COMPONENT)
          DO UA = 1, LOCAL_N_USERAZM
            DO IB = 1, NBEAMS
              DO UM = 1, N_USER_STREAMS
                AZM_ARGUMENT = USER_RELAZMS_ADJUST(UM,IB,UA) * DFC
                AZMFAC(UM,IB,UA,1)   = DCOS(DEG_TO_RAD*AZM_ARGUMENT)
                AZMFAC(UM,IB,UA,2)   = AZMFAC(UM,IB,UA,1)
                AZMFAC(UM,IB,UA,3)   = DSIN(DEG_TO_RAD*AZM_ARGUMENT)
                AZMFAC(UM,IB,UA,4)   = AZMFAC(UM,IB,UA,3)
              ENDDO
            ENDDO
          ENDDO
        ENDIF

C  Main call to VLidort Fourier module

c        write(*,*)' ..calculating fourier component',FOURIER_COMPONENT

        CALL VLIDORT_L_FOURIER_LAMBERTIAN
     I        ( FOURIER_COMPONENT,
     I          SS_FLUX_MULTIPLIER,
     O          DO_INCLUDE_SURFACE,
     O          DO_INCLUDE_SURFEMISS,
     O          DO_INCLUDE_THERMEMISS,
     O          STATUS_SUB )

C  error handling

        IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
          STATUS_CALCULATION = VLIDORT_SERIOUS
          WRITE(CF,'(I3)')FOURIER_COMPONENT
          MAIL = 'Error from VLIDORT_L_FOURIER_LAMBERTIAN, Fourier '//CF
          TRACE = 'Called by VLIDORT_L_MASTER_LAMBERTIAN'
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS_CALCULATION )
          CLOSE(VLIDORT_ERRUNIT)
          RETURN
        ENDIF

C  Fourier summation and Convergence examination
C  ---------------------------------------------

C   -- only done for beams which are still not converged.
C      This is controlled by flag DO_MULTIBEAM

C   -- new criterion, SS is added for Fourier = 0, as this means that
C      higher-order terms will be relatively smaller, which implies
C      faster convergence in some circumstances (generally not often).

        IBEAM_COUNT = 0
        DO IBEAM = 1, NBEAMS
          IF ( DO_MULTIBEAM ( IBEAM, FOURIER_COMPONENT ) ) THEN

C  Convergence and radiance summation

            CALL VLIDORT_CONVERGE
     I      ( AZMFAC, FOURIER_COMPONENT, LOCAL_N_USERAZM,
     O        BEAM_TESTCONV(IBEAM), IBEAM, BEAM_ITERATION(IBEAM) )

C  Fourier summation of linearization quantities

            IF ( DO_LINEARIZATION ) THEN
              CALL VLIDORT_L_CONVERGE
     &      ( AZMFAC, FOURIER_COMPONENT, LOCAL_N_USERAZM, IBEAM )
            ENDIF

C  Check number of beams already converged

            IF ( BEAM_ITERATION(IBEAM) ) THEN
              IBEAM_COUNT = IBEAM_COUNT + 1
            ELSE
              DO L = FOURIER_COMPONENT+1,MAXFOURIER
                DO_MULTIBEAM (IBEAM,L) = .FALSE.
              ENDDO
            ENDIF

C  end beam count loop

          ENDIF
        END DO

C  If all beams have converged, stop iteration

        IF ( IBEAM_COUNT .EQ. 0 ) LOCAL_ITERATION = .FALSE.

C  Fourier output
C  --------------

C  Open file if Fourier = 0
C  Write Standard   Fourier output (radiances)
C  Write additional Fourier output (linearizations)
C  Close file if iteration has finished
C  New comment:
C    If the SS correction is set, Fourier=0 will include SS field

        IF ( DO_WRITE_FOURIER ) THEN
          FUNIT = VLIDORT_FUNIT
          IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
            OPEN(FUNIT,FILE=FOURIER_WRITE_FILENAME,STATUS='UNKNOWN')
          ENDIF
          CALL VLIDORT_WRITEFOURIER ( FUNIT, FOURIER_COMPONENT )
          IF ( DO_LINEARIZATION ) THEN
            CALL VLIDORT_L_WRITEFOURIER
     I         ( DO_INCLUDE_SURFACE, FUNIT, FOURIER_COMPONENT )
          ENDIF
          IF ( .NOT.LOCAL_ITERATION ) CLOSE ( FUNIT )
        ENDIF

C  end iteration loop

      ENDDO

C  restore no azimuth flag

      DO_NO_AZIMUTH = SAVE_DO_NO_AZIMUTH

C  Major result output
C  ===================

C  Standard + linearized output
C  ----------------------------

      IF ( DO_WRITE_RESULTS ) THEN
        RUNIT = VLIDORT_RESUNIT
        OPEN(RUNIT,FILE=RESULTS_WRITE_FILENAME,STATUS='UNKNOWN')
        CALL VLIDORT_WRITERESULTS ( RUNIT )
        IF ( DO_LINEARIZATION ) THEN
          CALL VLIDORT_L_WRITERESULTS ( RUNIT )
        ENDIF
        CLOSE(RUNIT)
      ENDIF

C  Geophysical input (scenario) write
C  ----------------------------------

      IF ( DO_WRITE_SCENARIO ) THEN
        SUNIT = VLIDORT_SCENUNIT
        OPEN(SUNIT,FILE=SCENARIO_WRITE_FILENAME,STATUS='UNKNOWN')
        CALL VLIDORT_WRITESCEN ( SUNIT )
        IF ( DO_LINEARIZATION ) THEN
          CALL VLIDORT_L_WRITESCEN ( SUNIT )
        ENDIF
        CLOSE(SUNIT)
      ENDIF

C  Closing business
C  ================

C  close Error file if it was used

      IF ( .NOT. VLIDORT_ERROR_INIT ) CLOSE(VLIDORT_ERRUNIT)

C  Finish

      RETURN
      END

C

      SUBROUTINE VLIDORT_L_FOURIER_LAMBERTIAN
     I       ( FOURIER_COMPONENT,
     I         SS_FLUX_MULTIPLIER,
     O         DO_INCLUDE_SURFACE,
     O         DO_INCLUDE_SURFEMISS,
     O         DO_INCLUDE_THERMEMISS,
     O         STATUS )

C  Complete Fourier component calculation for the Extended Code
C    Stokes vector and Weighting function computations

C  Include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include file of input weighting function control variables

      INCLUDE '../includes/VLIDORT_L_INPUTS.VARS'

C  Include file of setup variables (output from SETUPS routine)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include this file file for debug only

      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'

C  module arguments
C  ----------------

C  Input Fourier component number

      INTEGER          FOURIER_COMPONENT

C  single scatter correction flux multiplier

      DOUBLE PRECISION SS_FLUX_MULTIPLIER

C  Output

      LOGICAL          DO_INCLUDE_SURFACE
      LOGICAL          DO_INCLUDE_SURFEMISS
      LOGICAL          DO_INCLUDE_THERMEMISS
      INTEGER          STATUS

C  Local variables
C  ---------------

      INTEGER          LAYER, IBEAM, IPARTIC, I, O1, N

C  local inclusion flags

      LOGICAL          DO_INCLUDE_MVOUTPUT
      LOGICAL          DO_INCLUDE_DIRECTBEAM

C  Flux multiplier and Fourier component numbers

      DOUBLE PRECISION FLUX_MULTIPLIER
      DOUBLE PRECISION DELTA_FACTOR
      DOUBLE PRECISION SURFACE_FACTOR

C  Lambertian surface:  external function calls

      EXTERNAL         BVP_LAMBERTIAN_SURFACE_HOM
      EXTERNAL         BVP_LAMBERTIAN_SURFACE_BEAM
      EXTERNAL         BOA_LAMBERTIAN_SOURCE

      EXTERNAL         L_BVP_LAMBERTIAN_SURFACE
      EXTERNAL         L_BOA_LAMBERTIAN_SOURCE

      EXTERNAL         LS_BVP_LAMBERTIAN_SURFACE
      EXTERNAL         LS_BOA_LAMBERTIAN_SOURCE

C  weighting function indices

      INTEGER          N_LAYER_WFS, LAYER_TO_VARY, N_PARAMETERS
      INTEGER          BRDF_INDEX, WF_INDEX
      LOGICAL          DO_RTSOL_VARY
      INTEGER          NPARAMS_VARY, VARIATION_INDEX

C  error tracing variables

      CHARACTER*(2)    C2
      CHARACTER*(70)   MAIL, TRACE
      INTEGER          STATUS_SUB
      LOGICAL          FAIL

C  progress

      logical          do_write_screen
      parameter       ( do_write_screen = .false. )

C  ##############
C  initialization
C  ##############

C  module status

      STATUS = VLIDORT_SUCCESS

C  Set local flags
C  ---------------

C  inclusion of thermal surface emission term, only for Fourier = 0

      DO_INCLUDE_SURFEMISS = .FALSE.
      IF ( DO_SURFACE_EMISSION ) THEN
        IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
          DO_INCLUDE_SURFEMISS = .TRUE.
        ENDIF
      ENDIF

C  inclusion of thermal emission term, only for Fourier = 0

      DO_INCLUDE_THERMEMISS = .FALSE.
      IF ( DO_THERMAL_EMISSION ) THEN
        IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
          DO_INCLUDE_THERMEMISS = .TRUE.
        ENDIF
      ENDIF

C  Surface flag (for inclusion of some kind of reflecting boundary)

      DO_INCLUDE_SURFACE = .TRUE.
      IF ( DO_LAMBERTIAN_SURFACE ) THEN
        IF ( FOURIER_COMPONENT .NE. 0 ) THEN
            DO_INCLUDE_SURFACE = .FALSE.
        ELSE
          IF ( LAMBERTIAN_ALBEDO .EQ. ZERO ) THEN
            DO_INCLUDE_SURFACE = .FALSE.
          ENDIF
        ENDIF
      ENDIF

C  Direct beam flag (only if above albedo flag has been set)
C   (DO_REFLECTED_DIRECTBEAM is a stored variable)

      IF ( DO_DIRECT_BEAM ) THEN
        IF ( DO_INCLUDE_SURFACE ) THEN
          DO IBEAM = 1, NBEAMS
            DO_REFLECTED_DIRECTBEAM(IBEAM) = .TRUE.
          ENDDO
        ELSE
          DO IBEAM = 1, NBEAMS
            DO_REFLECTED_DIRECTBEAM(IBEAM) = .FALSE.
          ENDDO
        ENDIF
      ENDIF

C  surface reflectance factors

      IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
        SURFACE_FACTOR = TWO
        DELTA_FACTOR   = ONE
      ELSE
        SURFACE_FACTOR = ONE
        DELTA_FACTOR   = TWO
      ENDIF

C  Flux multipliers

      FLUX_MULTIPLIER    = SS_FLUX_MULTIPLIER * DELTA_FACTOR
      IF ( DO_INCLUDE_THERMEMISS.AND..NOT.DO_SOLAR_SOURCES) THEN
        FLUX_MULTIPLIER = DELTA_FACTOR
      ENDIF

C  inclusion of mean value output

      DO_INCLUDE_MVOUTPUT = .FALSE.
      IF ( DO_ADDITIONAL_MVOUT. OR. DO_MVOUT_ONLY ) THEN
        IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
          DO_INCLUDE_MVOUTPUT = .TRUE.
        ENDIF
      ENDIF

C  Initialise BVP telescoping. Important.

      IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
        DO_BVTEL_INITIAL = DO_BVP_TELESCOPING
      ENDIF

C  #################
C  Set up operations
C  #################

C  Miscellaneous setups for Fourier = 0
C   MISCSETUPS   : Delta-M, average-secant formulation, transmittances
C   EMULT_MASTER : Beam source function multipliers. Not required for the
C                  Full SS calculation in outgoing mode

C  ############################ IMPORTANT NOTE, READ CAREFULLY #########
C
C  30 January 2008
C  Telescoping setup is done in DERIVE_INPUTS (unlike LIDORT scalar code)
C
C  ############################ IMPORTANT NOTE, READ CAREFULLY #########

      IF ( FOURIER_COMPONENT .EQ. 0 ) THEN

C  With linearization.

        IF ( DO_ATMOS_LINEARIZATION ) THEN

          CALL VLIDORT_MISCSETUPS
          CALL VLIDORT_L_MISCSETUPS
          IF ( DO_INCLUDE_THERMEMISS ) THEN
            CALL THERMAL_SETUP_PLUS
          ENDIF
          IF ( DO_SOLAR_SOURCES      ) THEN
            IF (.NOT.DO_SSFULL.OR.(DO_SSFULL.AND.DO_SSCORR_NADIR)) THEN
              CALL EMULT_MASTER
              CALL L_EMULT_MASTER
            ENDIF
          ENDIF

C  No linearization

        ELSE

          CALL VLIDORT_MISCSETUPS
          IF ( DO_INCLUDE_THERMEMISS ) THEN
            CALL THERMAL_SETUP
          ENDIF
          IF ( DO_SOLAR_SOURCES      ) THEN
            IF (.NOT.DO_SSFULL.OR.(DO_SSFULL.AND.DO_SSCORR_NADIR)) THEN
              CALL EMULT_MASTER
            ENDIF
          ENDIF

        ENDIF

C  End Fourier 0 clause

      ENDIF

C  #####################
C  Correction operations
C  #####################

C  Not required if no solar sources

      IF ( DO_SOLAR_SOURCES ) THEN

C  Single scatter correction (pre-calculation)
C  -------------------------------------------

C   Must be done after MISCSETUPS, as we need the multipliers and
C    transmittance factors for the SUN and LOS paths.
C   Standard Code added 6 May 2005. Replaces call in Master routine.
C   Linearized code 13 July 2005.  Replaces former code in L_Master module.

C      Version 2.2. Added call to the new outgoing sphericity correction
C      Version 2.4. Added call bulk/column linearizations

       IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
        IF ( DO_USER_STREAMS ) THEN

C  Regular (nadir view) SS correction

          IF ( DO_SSCORR_NADIR ) THEN
            CALL VLIDORT_SSCORR_NADIR ( SS_FLUX_MULTIPLIER )
            IF ( DO_PROFILE_LINEARIZATION ) THEN
              DO LAYER_TO_VARY = 1, NLAYERS
                IF ( LAYER_VARY_FLAG(LAYER_TO_VARY) ) THEN
                  N_PARAMETERS = LAYER_VARY_NUMBER(LAYER_TO_VARY)
                  CALL VLIDORT_LP_SSCORR_NADIR
     &            ( SS_FLUX_MULTIPLIER, LAYER_TO_VARY, N_PARAMETERS)
                ENDIF
              ENDDO
            ENDIF
            IF ( DO_COLUMN_LINEARIZATION ) THEN
              CALL VLIDORT_LC_SSCORR_NADIR
     &            ( SS_FLUX_MULTIPLIER, N_TOTALCOLUMN_WFS)
            ENDIF
          ENDIF

C  Outgoing sphericity correction ------ Added 20 March 2007.
C     Calling not changed for column Jacobians (Version 2.4, December 2008)

          IF ( DO_SSCORR_OUTGOING ) THEN
           IF ( DO_ATMOS_LINEARIZATION ) THEN
            CALL VLIDORT_L_SSCORR_OUTGOING
     &     ( SS_FLUX_MULTIPLIER, FAIL, MAIL )
            IF ( FAIL ) THEN
              TRACE= 'Linearized SS correction outgoing failed'
              STATUS = VLIDORT_SERIOUS
              CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
              RETURN
            ENDIF
           ELSE
            CALL VLIDORT_SSCORR_OUTGOING
     &     ( SS_FLUX_MULTIPLIER, FAIL, MAIL )
            IF ( FAIL ) THEN
              TRACE= 'SS correction outgoing failed'
              STATUS = VLIDORT_SERIOUS
              CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
              RETURN
            ENDIF
           ENDIF
          ENDIF

C  End fourier = 0, user stream and solar source  clauses

        ENDIF
       ENDIF
      ENDIF

C  Exact direct beam BRDF (if flagged)
C  -----------------------------------

C  THIS IS THE LAMBERTIAN MASTER, SO CODE NOT REQUIRED

C   Must be done after MISCSETUPS, as we need the SUN transmittance factors
C   BRDF Kernels already known (called before this module)
C   Code added 6 May 2005. Standard case.
C   Profile/surface Linearization code added July 13 2005.
C     Column        Linearization code added December 2008

c      IF ( FOURIER_COMPONENT .EQ. 0 ) THEN
c        IF ( DO_USER_STREAMS ) THEN
c          IF ( DO_DBCORRECTION ) THEN
c            CALL VLIDORT_DBCORRECTION ( SS_FLUX_MULTIPLIER )
c            IF ( DO_PROFILE_LINEARIZATION ) THEN
c              DO LAYER_TO_VARY = 1, NLAYERS
c                IF ( LAYER_VARY_FLAG(LAYER_TO_VARY) ) THEN
c                  N_PARAMETERS = LAYER_VARY_NUMBER(LAYER_TO_VARY)
c                  CALL VLIDORT_LAP_DBCORRECTION
c     &            ( SS_FLUX_MULTIPLIER, LAYER_TO_VARY, N_PARAMETERS)
c                ENDIF
c              ENDDO
c            ENDIF
c            IF ( DO_COLUMN_LINEARIZATION ) THEN
c              CALL VLIDORT_LAC_DBCORRECTION
c     &           ( SS_FLUX_MULTIPLIER, N_TOTALCOLUMN_WFS )
c            ENDIF
c            IF ( DO_SURFACE_LINEARIZATION ) THEN
c              CALL VLIDORT_LS_DBCORRECTION
c            ENDIF
c          ENDIF
c        ENDIF
c      ENDIF

C  BRDF Fourier components - coefficient setup
C   (also computes emissivity if required)

c      IF ( .NOT. DO_LAMBERTIAN_SURFACE ) THEN
c        CALL VLIDORT_BRDF_FRTERMS
c     I    ( DO_INCLUDE_SURFACE,
c     I      DO_INCLUDE_SURFEMISS,
c     I      FOURIER_COMPONENT,
c     I      DELTA_FACTOR )
c      ENDIF

C  Linearization of BRDF Fourier components

c      IF ( .NOT. DO_LAMBERTIAN_SURFACE ) THEN
c        CALL VLIDORT_L_BRDF_FRTERMS
c     I    ( DO_INCLUDE_SURFACE,
c     I      DO_INCLUDE_SURFEMISS,
c     I      DELTA_FACTOR )
c      ENDIF

C  Do the DB-corrected Reflected Direct beam attenuation (Lambertian)
C         --- when DO_SSFULL (only single scatter result)
C         --- when Full Radinace + DB correction is flagged
C  Otherwise, direct beam term is set by internal post-processing

      IF ( DO_SOLAR_SOURCES ) THEN
       IF ( DO_SSFULL.OR.(.NOT.DO_SSFULL.AND.DO_DBCORRECTION) ) THEN
        CALL VLIDORT_LAMBERTIAN_DBCORR (SS_FLUX_MULTIPLIER)
        IF ( DO_PROFILE_LINEARIZATION ) THEN
          CALL VLIDORT_LAP_LAMBERTIAN_DBCORR (SS_FLUX_MULTIPLIER)
        ENDIF
        IF ( DO_COLUMN_LINEARIZATION ) THEN
          CALL VLIDORT_LAC_LAMBERTIAN_DBCORR (SS_FLUX_MULTIPLIER)
        ENDIF
        IF ( DO_SURFACE_LINEARIZATION ) THEN
          CALL VLIDORT_LS_LAMBERTIAN_DBCORR
        ENDIF
       ELSE
        CALL LAMBERTIAN_SURFACE_DIRECTBEAM
     I    ( FOURIER_COMPONENT, DELTA_FACTOR )
       ENDIF
      ENDIF

C  Full single scatter calculation, return after completion

      IF ( DO_SSFULL ) RETURN

C  ###############################################################
C     END OF SSCORRECTION STUFF
C  ###############################################################

C  Get Pi Matrices for this Fourier component
C    Including all beam angles !!

      IF ( .NOT. DO_THERMAL_TRANSONLY ) THEN
        CALL VLIDORT_PIMATRIX_SETUP ( FOURIER_COMPONENT )
      ENDIF

C  #########################################################
C  RT differential equation Eigensolutions + linearizations
C  #########################################################

C  Go to continuation point for thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY ) GO TO 8899

C  Start layer loop

      DO LAYER = 1, NLAYERS

C  Get Discrete ordinate solutions for this layer

        CALL VLIDORT_QHOM_SOLUTION
     I    ( LAYER, FOURIER_COMPONENT,
     O      STATUS_SUB )

C  .. error tracing

        IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
          MAIL = 'Error return from module VLIDORT_QHOM_SOLUTION'
          TRACE= 'Call #1 in VLIDORT_L_FOURIER_LAMBERTIAN'
          STATUS = VLIDORT_SERIOUS
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
        ENDIF

C  Get Post-processing ("user") solutions for this layer

        IF  ( STERM_LAYERMASK_UP(LAYER) .OR.
     &        STERM_LAYERMASK_DN(LAYER) ) THEN
          IF ( DO_USER_STREAMS ) THEN
            CALL VLIDORT_UHOM_SOLUTION
     I           ( LAYER, FOURIER_COMPONENT )
          ENDIF
        ENDIF

C  Additional Solutions for Linearization
C  --------------------------------------

        IF ( DO_ATMOS_LINEARIZATION ) THEN

C  Parameter control

          IF ( DO_PROFILE_LINEARIZATION ) THEN
            DO_RTSOL_VARY = LAYER_VARY_FLAG(LAYER)
            NPARAMS_VARY  = LAYER_VARY_NUMBER(LAYER)
          ELSE IF ( DO_COLUMN_LINEARIZATION ) THEN
            DO_RTSOL_VARY = .TRUE.
            NPARAMS_VARY  = N_TOTALCOLUMN_WFS
          ENDIF

C  Linearizations of Discrete Ordinate solution

c         if ( do_write_screen) write(*,*)'l_homsolution',layer
          CALL VLIDORT_L_QHOM_SOLUTION
     I      ( LAYER, FOURIER_COMPONENT,
     I        DO_RTSOL_VARY,
     I        NPARAMS_VARY,
     O        STATUS_SUB )

C  .. error tracing

          IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
            MAIL = 'Error return from module VLIDORT_L_QHOM_SOLUTION'
            TRACE= 'Call #2 in VLIDORT_L_FOURIER_LAMBERTIAN'
            STATUS = VLIDORT_SERIOUS
            CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
            RETURN
          ENDIF

C  Get Linearizations of ("user") solutions for this layer

          CALL VLIDORT_L_UHOM_SOLUTION
     I      ( LAYER, FOURIER_COMPONENT,
     I        DO_RTSOL_VARY,
     I        NPARAMS_VARY )

C  End linearization control

        ENDIF

C  end layer loop

      ENDDO

C  Prepare homogeneous solution multipliers

      CALL HMULT_MASTER
      IF ( DO_ATMOS_LINEARIZATION ) THEN
        CALL L_HMULT_MASTER
      ENDIF

C  ############################################
C   boundary value problem - MATRIX PREPARATION
C  ############################################

C  standard case using compression of band matrices, etc..

      IF ( BVP_REGULAR_FLAG(FOURIER_COMPONENT) ) THEN

        CALL BVP_MATRIXSETUP_MASTER
     I     ( DO_INCLUDE_SURFACE,
     I       FOURIER_COMPONENT,
     I       SURFACE_FACTOR,
     I       BVP_LAMBERTIAN_SURFACE_HOM,
     O       STATUS_SUB )

        IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
          MAIL = 'Error return from module BVPMATRIX_SETUP_MASTER'
          TRACE= 'Call #3 in VLIDORT_L_FOURIER_LAMBERTIAN'
          STATUS = VLIDORT_SERIOUS
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
        ENDIF

C  Telescoped case

      ELSE

        CALL BVPTEL_MATRIXSETUP_MASTER
     I     ( DO_INCLUDE_SURFACE,
     I       FOURIER_COMPONENT,
     I       SURFACE_FACTOR,
     I       BVP_LAMBERTIAN_SURFACE_HOM,
     O       STATUS_SUB )

        IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
          MAIL = 'Error return from module BVPTEL_MATRIXSETUP_MASTER'
          TRACE= 'Call #4 in VLIDORT_L_FOURIER_LAMBERTIAN'
          STATUS = VLIDORT_SERIOUS
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
        ENDIF

      ENDIF

C  ################
C  Thermal Solution (2 steps)
C  ################

C  Continuation point for avoiding the scattering calculations

 8899 continue

C  THERMAL SOLUTIONS
C  =================

C  Separate calls if linearization is required

C  1. Find the Particular solution (also for transmittance only)
C  2. Compute thermal layer source terms. (Upwelling and Downwelling)
C    These will be scaled up by factor 4.pi if solar beams as well

      IF ( DO_INCLUDE_THERMEMISS ) THEN

C  With linearization

       IF ( DO_ATMOS_LINEARIZATION ) THEN
         CALL THERMAL_CLSOLUTION_PLUS ( STATUS_SUB, MAIL )
         IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
           TRACE  = 'Call #4A in VLIDORT_L_FOURIER_LAMBERTIAN'
           STATUS = VLIDORT_SERIOUS
           CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
           RETURN
         ENDIF
         IF ( DO_UPWELLING ) CALL THERMAL_STERMS_UP_PLUS
         IF ( DO_DNWELLING ) CALL THERMAL_STERMS_DN_PLUS

C  No linearization

       ELSE
         CALL THERMAL_CLSOLUTION ( STATUS_SUB, MAIL )
         IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
           TRACE  = 'Call #4B in VLIDORT_L_FOURIER_LAMBERTIAN'
           STATUS = VLIDORT_SERIOUS
           CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
           RETURN
         ENDIF
         IF ( DO_UPWELLING ) CALL THERMAL_STERMS_UP
         IF ( DO_DNWELLING ) CALL THERMAL_STERMS_DN
       ENDIF

!  End include thermal emission

      ENDIF

C  Skip the thermal-only section if there are solar sources

      IF ( DO_SOLAR_SOURCES ) GO TO 455

C  ####################################################
C  Complete Radiation Field with Thermal-only solutions
C  ####################################################

C    Only one solution, local direct_beam flag NOT set

      IPARTIC = 1
      DO_INCLUDE_DIRECTBEAM   = .FALSE.

C  Avoid the scattering solutions if not flagged

      IF ( DO_THERMAL_TRANSONLY ) GO TO 566

C  Thermal-only. Find the BVP solution and intensity field
C  -------------------------------------------------------

C  set the BVP PI solution at the lower/upper boundaries

      O1 = 1
      DO LAYER = 1, NLAYERS
        DO I = 1, NSTREAMS_2
          WUPPER(I,O1,LAYER) = T_WUPPER(I,LAYER)
          WLOWER(I,O1,LAYER) = T_WLOWER(I,LAYER)
       ENDDO
      ENDDO

C  Solve the boundary value problem. No telescoping here

      CALL BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_INCLUDE_DIRECTBEAM,
     I         DO_INCLUDE_SURFEMISS,
     I         FOURIER_COMPONENT, IPARTIC,
     I         SURFACE_FACTOR,
     I         BVP_LAMBERTIAN_SURFACE_BEAM,
     O         STATUS_SUB )

C  Error handling

      IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
        MAIL = 'Error return from module BVP_SOLUTION_MASTER'
        TRACE= 'Call #5A in VLIDORT_L_FOURIER_LAMBERTIAN'
        STATUS = VLIDORT_SERIOUS
        CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
        RETURN
      ENDIF

C  Continuation point for avoiding thermal scattering

 566  CONTINUE

C  Post-processing - upwelling thermal-only field

      IF ( DO_UPWELLING ) THEN
        CALL VLIDORT_UPUSER_INTENSITY
     I        ( DO_INCLUDE_SURFACE,
     I          DO_INCLUDE_SURFEMISS,
     I          DO_INCLUDE_THERMEMISS,
     I          DO_INCLUDE_DIRECTBEAM,
     I          DO_INCLUDE_MVOUTPUT,
     I          FOURIER_COMPONENT,  IPARTIC,
     I          SURFACE_FACTOR,
     I          BOA_LAMBERTIAN_SOURCE,
     I          FLUX_MULTIPLIER )
      ENDIF

C  Post-processing - Downwelling thermal-only field

      IF ( DO_DNWELLING ) THEN
        CALL VLIDORT_DNUSER_INTENSITY
     I        ( DO_INCLUDE_THERMEMISS,
     I          FLUX_MULTIPLIER,
     I          FOURIER_COMPONENT,
     I          IPARTIC )
      ENDIF

C  mean value (integrated) output for thermal-only field
C    ------- Can also use this to get debug Quadrature output

      IF ( DO_INCLUDE_MVOUTPUT.OR.DO_QUAD_OUTPUT ) THEN
         CALL VLIDORT_INTEGRATED_OUTPUT
     I      ( DO_INCLUDE_MVOUTPUT,
     I        DO_INCLUDE_DIRECTBEAM,
     I        DO_INCLUDE_THERMEMISS,
     I        FLUX_MULTIPLIER, IPARTIC )
      ENDIF

C  LTE linearization (new section, 14 September 2009)
C  --------------------------------------------------

      if ( DO_THERMAL_TRANSONLY .and. do_LTE_linearization ) then
         CALL THERMAL_LTE_LINEARIZATION
     &   ( DO_INCLUDE_SURFACE, SURFACE_FACTOR, FLUX_MULTIPLIER )
      endif

C  Thermal-only: Atmospheric profile linearization
C  -----------------------------------------------

      IF ( DO_PROFILE_LINEARIZATION ) THEN

C  Start over layers that will contain variations
C    - Set flag for variation of layer, and number of variations

        DO LAYER_TO_VARY = 1, NLAYERS
          IF ( LAYER_VARY_FLAG(LAYER_TO_VARY) ) THEN
            N_LAYER_WFS = LAYER_VARY_NUMBER(LAYER_TO_VARY)

C  Avoidance of BVP problem for transmittance only

            IF ( DO_THERMAL_TRANSONLY ) GO TO 788

C  Solve the Regular BVP linearization

            IF ( BVP_REGULAR_FLAG(FOURIER_COMPONENT) ) THEN

C  Get the BVP solution (regular case) for this beam component

              CALL L_BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_INCLUDE_DIRECTBEAM,
     I         DO_INCLUDE_THERMEMISS,
     I         LAYER_TO_VARY, N_LAYER_WFS,
     I         FOURIER_COMPONENT, IPARTIC, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
               MAIL = 'Error in L_BVP_SOLUTION_MASTER, Prof/Lin'
               TRACE= 'Call #5B in VLIDORT_L_FOURIER_LAMBERTIAN'
               STATUS = VLIDORT_SERIOUS
               CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
               RETURN
              ENDIF

            ENDIF

C  Continuation point for avoiding scattering solution

 788        CONTINUE

C  Post-processing for the weighting functions, Sequence:
C    Upwelling   Atmospheric weighting functions
C    Downwelling Atmospheric weighting functions
C    Mean-value  Atmospheric weighting functions

            IF ( DO_UPWELLING ) THEN
              CALL VLIDORT_UPUSER_ATMOSWF
     I         ( DO_INCLUDE_SURFACE,
     I           DO_INCLUDE_THERMEMISS,
     I           DO_INCLUDE_MVOUTPUT,
     I           DO_INCLUDE_DIRECTBEAM,
     I           SURFACE_FACTOR,      FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IPARTIC,
     I           LAYER_TO_VARY,       N_LAYER_WFS,
     I           L_BOA_LAMBERTIAN_SOURCE )
            ENDIF

            IF ( DO_DNWELLING ) THEN
              CALL VLIDORT_DNUSER_ATMOSWF
     I         ( DO_INCLUDE_THERMEMISS,
     I           FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IPARTIC,
     I           LAYER_TO_VARY,       N_LAYER_WFS )
            ENDIF

            IF ( DO_INCLUDE_MVOUTPUT .OR. DO_QUAD_OUTPUT ) THEN
              CALL VLIDORT_L_INTEGRATED_OUTPUT
     I            ( DO_INCLUDE_MVOUTPUT,
     I              DO_INCLUDE_DIRECTBEAM,
     I              DO_INCLUDE_THERMEMISS,
     I              FLUX_MULTIPLIER,
     I              IPARTIC, LAYER_TO_VARY, N_LAYER_WFS )
            ENDIF

C  Finish loop over layers with variation

          ENDIF
        ENDDO

C  End atmospheric profile weighting functions

      ENDIF

C  Thermal Only: Atmospheric Bulk weighting functions
C  --------------------------------------------------

      IF ( DO_COLUMN_LINEARIZATION ) THEN

C   variation index = 0

        VARIATION_INDEX = 0

C  Avoidance of BVP problem for transmittance only

        IF ( DO_THERMAL_TRANSONLY ) GO TO 789

C  Get the linearized BVP solution for this beam component

        CALL L_BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_INCLUDE_DIRECTBEAM,
     I         DO_INCLUDE_THERMEMISS,
     I         VARIATION_INDEX, N_TOTALCOLUMN_WFS,
     I         FOURIER_COMPONENT, IBEAM, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

        IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
          MAIL = 'Error in module L_BVP_SOLUTION_MASTER, Col/lin'
          TRACE= 'Call #5C in VLIDORT_L_FOURIER_LAMBERTIAN'
          STATUS = VLIDORT_SERIOUS
          CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
        ENDIF

C  Continuation point for avoiding scattering solution

 789    CONTINUE

C  Post-processing for the weighting functions, Sequence:
C    Upwelling   Atmospheric weighting functions
C    Downwelling Atmospheric weighting functions
C    Mean-value  Atmospheric weighting functions

        IF ( DO_UPWELLING ) THEN
          CALL VLIDORT_UPUSER_ATMOSWF
     I         ( DO_INCLUDE_SURFACE,
     I           DO_INCLUDE_THERMEMISS,
     I           DO_INCLUDE_MVOUTPUT,
     I           DO_INCLUDE_DIRECTBEAM,
     I           SURFACE_FACTOR,      FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IPARTIC,
     I           VARIATION_INDEX,     N_TOTALCOLUMN_WFS,
     I           L_BOA_LAMBERTIAN_SOURCE )
        ENDIF

        IF ( DO_DNWELLING ) THEN
          CALL VLIDORT_DNUSER_ATMOSWF
     I         ( DO_INCLUDE_THERMEMISS,
     I           FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IPARTIC,
     I           VARIATION_INDEX,     N_TOTALCOLUMN_WFS )
        ENDIF

        IF ( DO_INCLUDE_MVOUTPUT .OR. DO_QUAD_OUTPUT ) THEN
          CALL VLIDORT_L_INTEGRATED_OUTPUT
     I            ( DO_INCLUDE_MVOUTPUT,
     I              DO_INCLUDE_DIRECTBEAM,
     I              DO_INCLUDE_THERMEMISS,
     I              FLUX_MULTIPLIER,
     I              IPARTIC, VARIATION_INDEX, N_TOTALCOLUMN_WFS )
        ENDIF

C  End atmospheric column weighting functions

      ENDIF

C  Thermal-only: Surface Reflectance weighting functions
C  -----------------------------------------------------

      IF ( DO_SURFACE_LINEARIZATION ) THEN

C  initialise weighting function count

        WF_INDEX = 1
        BRDF_INDEX = 1

C  Only do this if there is surface reflectance !

        IF ( DO_INCLUDE_SURFACE ) THEN

C  Lambertian albedo weighting function

          CALL VLIDORT_ALBEDO_WFS
     I           (  DO_REFLECTED_DIRECTBEAM,
     I              DO_INCLUDE_SURFEMISS,
     I              DO_INCLUDE_MVOUTPUT,
     I              BVP_REGULAR_FLAG(FOURIER_COMPONENT),
     I              FOURIER_COMPONENT, IPARTIC,
     I              SURFACE_FACTOR,
     I              FLUX_MULTIPLIER,
     I              BRDF_INDEX, WF_INDEX,
     I              LS_BVP_LAMBERTIAN_SURFACE,
     I              LS_BOA_LAMBERTIAN_SOURCE,
     O              STATUS_SUB )

          IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
            MAIL = 'Error in module VLIDORT_ALBEDO_WFS'
            TRACE= 'Call #5D in VLIDORT_L_FOURIER_LAMBERTIAN'
            STATUS = VLIDORT_SERIOUS
            CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
            RETURN
          ENDIF

        ENDIF

C  end of albedo weighting functions

      ENDIF

C  Finish Thermal only.

      RETURN

C  ##################################################
C  Complete Radiation Field with Solar Beam solutions
C  ##################################################

C  Continuation point

 455  CONTINUE

C  Start loop over desired beam solutions

      DO IBEAM = 1, NBEAMS

        IF ( DO_MULTIBEAM(IBEAM,FOURIER_COMPONENT) ) THEN

C  Step 1. Solar beam Particular solutions + linearizations
C  --------------------------------------------------------

          DO LAYER = 1, NLAYERS

C  Parameter control for the linearization

            IF ( DO_ATMOS_LINEARIZATION ) THEN
              IF ( DO_PROFILE_LINEARIZATION ) THEN
                DO_RTSOL_VARY = LAYER_VARY_FLAG(LAYER)
                NPARAMS_VARY  = LAYER_VARY_NUMBER(LAYER)
              ELSE IF ( DO_COLUMN_LINEARIZATION ) THEN
                DO_RTSOL_VARY = .TRUE.
                NPARAMS_VARY  = N_TOTALCOLUMN_WFS
              ENDIF
            ENDIF

C  A. the classical solution
C     ++++++++++++++++++++++

            IF ( DO_CLASSICAL_SOLUTION ) THEN

C  For the particular integral itself

              CALL  VLIDORT_QBEAM_SOLUTION
     I         ( LAYER, FOURIER_COMPONENT, IBEAM, STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
                WRITE(C2,'(I2)')LAYER
                MAIL = 'Error from VLIDORT_QBEAM_SOLUTION, layer'//C2
                TRACE= 'Call #6A in VLIDORT_L_FOURIER_LAMBERTIAN'
                STATUS = VLIDORT_SERIOUS
                CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
                RETURN
              ENDIF

C  For the linearizations of the classical solution

              IF ( DO_ATMOS_LINEARIZATION ) THEN

                CALL VLIDORT_L_QBEAM_SOLUTION
     I            ( LAYER, FOURIER_COMPONENT, IBEAM,
     I              DO_RTSOL_VARY,
     I              NPARAMS_VARY,
     O              STATUS_SUB )

                IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
                  MAIL =
     &             'Error return from module VLIDORT_L_QBEAM_SOLUTION'
                  TRACE= 'Call #6B in VLIDORT_L_FOURIER_LAMBERTIAN'
                  STATUS = VLIDORT_SERIOUS
                  CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
                  RETURN
                ENDIF

              ENDIF

C  B. the Green's function solution
C  ++++++++++++++++++++++++++++++++

            ELSE

C  $$$$$$$$$$$$$$$$$$$$$$    P L A C E H O L D E R    $$$$$$$$$$$$$$$$$$$$
C            CALL V_GREENFUNC_SOLUTION ( FOURIER)
C  $$$$$$$$$$$$$$$$$$$$$$    P L A C E H O L D E R    $$$$$$$$$$$$$$$$$$$$

            ENDIF

C  C. user solutions
C  +++++++++++++++++

            IF  ( STERM_LAYERMASK_UP(LAYER) .OR.
     &            STERM_LAYERMASK_DN(LAYER) ) THEN
              IF ( DO_USER_STREAMS ) THEN

C  (classical)
                IF ( DO_CLASSICAL_SOLUTION ) THEN

                  CALL VLIDORT_UBEAM_SOLUTION
     I             ( LAYER, FOURIER_COMPONENT, IBEAM )
                  IF ( DO_ATMOS_LINEARIZATION ) THEN
                    CALL VLIDORT_L_UBEAM_SOLUTION
     I               ( LAYER, FOURIER_COMPONENT, IBEAM,
     I                 DO_RTSOL_VARY,
     I                 NPARAMS_VARY )
                  ENDIF

C  (Green's function)

                ELSE
C  $$$$$$$$$$$$$$$$$$$$$$    P L A C E H O L D E R    $$$$$$$$$$$$$$$$$$$$
C            CALL V_GREENFUNC_SOLUTION ( FOURIER)
C  $$$$$$$$$$$$$$$$$$$$$$    P L A C E H O L D E R    $$$$$$$$$$$$$$$$$$$$
                ENDIF

              END IF
            END IF

C  end layer loop

          END DO

C  Add thermal solutions if flagged
C    4.PI modulus on the thermal contribution.

          IF ( DO_INCLUDE_THERMEMISS ) THEN
            O1 = 1
            DO N = 1, NLAYERS
              DO I = 1, NSTREAMS_2
                WUPPER(I,O1,N) = WUPPER(I,O1,N) + PI4 * T_WUPPER(I,N)
                WLOWER(I,O1,N) = WLOWER(I,O1,N) + PI4 * T_WLOWER(I,N)
              ENDDO
            ENDDO
          ENDIF

C  Adding the linearized thermal solutions is done later.....

C  Step 2. Solve boundary value problem and get Stokes vector
C  ----------------------------------------------------------

C  2A. Boundary Value problem
C  ==========================

C  standard case using compressed-band matrices, etc..

c       if ( do_write_screen) write(*,*)'bvp solution',ibeam
          IF ( BVP_REGULAR_FLAG(FOURIER_COMPONENT) ) THEN

C  Get the BVP solution (regular case) for this beam component

            CALL BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_REFLECTED_DIRECTBEAM(IBEAM),
     I         DO_INCLUDE_SURFEMISS,
     I         FOURIER_COMPONENT, IBEAM,
     I         SURFACE_FACTOR,
     I         BVP_LAMBERTIAN_SURFACE_BEAM,
     O         STATUS_SUB )

            IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
              MAIL = 'Error return from module BVP_SOLUTION_MASTER'
              TRACE= 'Call #7A in VLIDORT_L_FOURIER_LAMBERTIAN'
              STATUS = VLIDORT_SERIOUS
              CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
              RETURN
            ENDIF

C  Telescoped case

          ELSE

            CALL BVPTEL_SOLUTION_MASTER
     I         ( DO_INCLUDE_SURFACE,
     I           DO_REFLECTED_DIRECTBEAM(IBEAM),
     I           FOURIER_COMPONENT, IBEAM,
     I           SURFACE_FACTOR,
     I           BVP_LAMBERTIAN_SURFACE_BEAM,
     O           STATUS_SUB )

            IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
              MAIL = 'Error return from module BVPTEL_SOLUTION_MASTER'
              TRACE= 'Call #7B in VLIDORT_L_FOURIER_LAMBERTIAN'
              STATUS = VLIDORT_SERIOUS
              CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
              RETURN
            ENDIF

          ENDIF

C  2B. Stokes vector Post Processing
C  =================================

C  upwelling

          IF ( DO_UPWELLING ) THEN

            DO_INCLUDE_DIRECTBEAM =
     &      (DO_REFLECTED_DIRECTBEAM(IBEAM).AND..NOT.DO_DBCORRECTION)

            CALL VLIDORT_UPUSER_INTENSITY
     I        ( DO_INCLUDE_SURFACE,
     I          DO_INCLUDE_SURFEMISS,
     I          DO_INCLUDE_THERMEMISS,
     I          DO_INCLUDE_DIRECTBEAM,
     I          DO_INCLUDE_MVOUTPUT,
     I          FOURIER_COMPONENT,  IBEAM,
     I          SURFACE_FACTOR,
     I          BOA_LAMBERTIAN_SOURCE,
     I          FLUX_MULTIPLIER )
          ENDIF

C  Downwelling

          IF ( DO_DNWELLING ) THEN
            CALL VLIDORT_DNUSER_INTENSITY
     I        ( DO_INCLUDE_THERMEMISS,
     I          FLUX_MULTIPLIER,
     I          FOURIER_COMPONENT, IBEAM )
          ENDIF

C  mean value (integrated) output.
C    ------- Can also use this to get debug Quadrature output

          IF ( DO_INCLUDE_MVOUTPUT.OR.DO_QUAD_OUTPUT ) THEN
            CALL VLIDORT_INTEGRATED_OUTPUT
     I      ( DO_INCLUDE_MVOUTPUT,
     I        DO_REFLECTED_DIRECTBEAM(IBEAM),
     I        DO_INCLUDE_THERMEMISS,
     &        FLUX_MULTIPLIER, IBEAM )
          ENDIF

C  Finished this Beam solution, if only Stokes vector is required

          IF ( DO_SIMULATION_ONLY ) GO TO 4000

C  Step 3. Atmospheric Profile weighting function loop
C  ---------------------------------------------------

          IF ( DO_PROFILE_LINEARIZATION ) THEN

C  Start over layers that will contain variations
C    - Set flag for variation of layer, and number of variations

           DO LAYER_TO_VARY = 1, NLAYERS
            IF ( LAYER_VARY_FLAG(LAYER_TO_VARY) ) THEN
             N_LAYER_WFS = LAYER_VARY_NUMBER(LAYER_TO_VARY)

C  3A. Solve the linearized BVP
C  ============================

C  Get the linearized BVP solution for this beam component

C    (a) Regular case (full matrix linearization)

             IF ( BVP_REGULAR_FLAG(FOURIER_COMPONENT) ) THEN

              CALL L_BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_REFLECTED_DIRECTBEAM(IBEAM),
     I         DO_INCLUDE_THERMEMISS,
     I         LAYER_TO_VARY, N_LAYER_WFS,
     I         FOURIER_COMPONENT, IBEAM, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
               MAIL = 'Error in module L_BVP_SOLUTION_MASTER'
               TRACE= 'Call #8A in VLIDORT_L_FOURIER_LAMBERTIAN'
               STATUS = VLIDORT_SERIOUS
               CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
               RETURN
              ENDIF

C    (b) telescoped case

            ELSE

             CALL L_BVPTEL_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_REFLECTED_DIRECTBEAM(IBEAM),
     I         LAYER_TO_VARY, N_LAYER_WFS,
     I         FOURIER_COMPONENT, IBEAM, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
               MAIL = 'Error in module L_BVPTEL_SOLUTION_MASTER'
               TRACE= 'Call #8B in VLIDORT_L_FOURIER_LAMBERTIAN'
               STATUS = VLIDORT_SERIOUS
               CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
               RETURN
              ENDIF

            ENDIF

C  3B. Post-processing for the weighting functions
C  ===============================================

C  Sequence:
C    Upwelling   Atmospheric weighting functions
C    Downwelling Atmospheric weighting functions
C    Mean-value  Atmospheric weighting functions

             IF ( DO_UPWELLING ) THEN
C            if ( do_write_screen) write(*,*)'wf up',ibeam,layer_to_vary
               CALL VLIDORT_UPUSER_ATMOSWF
     I         ( DO_INCLUDE_SURFACE,
     I           DO_INCLUDE_THERMEMISS,
     I           DO_INCLUDE_MVOUTPUT,
     I           DO_REFLECTED_DIRECTBEAM(IBEAM),
     I           SURFACE_FACTOR,      FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IBEAM,
     I           LAYER_TO_VARY,       N_LAYER_WFS,
     I           L_BOA_LAMBERTIAN_SOURCE )
             ENDIF

             IF ( DO_DNWELLING ) THEN
C           if ( do_write_screen) write(*,*)'wf dn',ibeam,layer_to_vary
              CALL VLIDORT_DNUSER_ATMOSWF
     I         ( DO_INCLUDE_THERMEMISS,
     I           FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IBEAM,
     I           LAYER_TO_VARY,       N_LAYER_WFS )
             ENDIF

             IF ( DO_INCLUDE_MVOUTPUT .OR. DO_QUAD_OUTPUT ) THEN
              CALL VLIDORT_L_INTEGRATED_OUTPUT
     I            ( DO_INCLUDE_MVOUTPUT,
     I              DO_INCLUDE_DIRECTBEAM,
     I              DO_INCLUDE_THERMEMISS,
     I              FLUX_MULTIPLIER,
     I              IBEAM, LAYER_TO_VARY, N_LAYER_WFS )
             ENDIF

C  Finish loop over layers with variation

            ENDIF
           ENDDO

C  End profile atmospheric weighting functions

          ENDIF

C  Step 4. Atmospheric Bulk weighting functions
C  --------------------------------------------

          IF ( DO_COLUMN_LINEARIZATION ) THEN

C   variation index = 0

            VARIATION_INDEX = 0

C  4A. Solve the linearized BVP
C  ============================

C  (a) Regular BVP linearization

            IF ( BVP_REGULAR_FLAG(FOURIER_COMPONENT) ) THEN

C  Get the linearized BVP solution for this beam component

              CALL L_BVP_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_REFLECTED_DIRECTBEAM(IBEAM),
     I         DO_INCLUDE_THERMEMISS,
     I         VARIATION_INDEX, N_TOTALCOLUMN_WFS,
     I         FOURIER_COMPONENT, IBEAM, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
               MAIL = 'Error in module L_BVP_SOLUTION_MASTER'
               TRACE= 'Call #9A in VLIDORT_L_FOURIER_LAMBERTIAN'
               STATUS = VLIDORT_SERIOUS
               CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
               RETURN
              ENDIF

C  (b) telescoped BVP linearization

            ELSE

              CALL L_BVPTEL_SOLUTION_MASTER
     I       ( DO_INCLUDE_SURFACE,
     I         DO_REFLECTED_DIRECTBEAM(IBEAM),
     I         VARIATION_INDEX, N_TOTALCOLUMN_WFS,
     I         FOURIER_COMPONENT, IBEAM, SURFACE_FACTOR,
     I         L_BVP_LAMBERTIAN_SURFACE,
     O         STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
               MAIL = 'Error in module L_BVPTEL_SOLUTION_MASTER'
               TRACE= 'Call #9B in VLIDORT_L_FOURIER_LAMBERTIAN'
               STATUS = VLIDORT_SERIOUS
               CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
               RETURN
              ENDIF

            ENDIF

C  4B. Post-processing for the weighting functions
C  ===============================================

C  Sequence:
C    Upwelling   Atmospheric weighting functions
C    Downwelling Atmospheric weighting functions
C    Mean-value  Atmospheric weighting functions

            IF ( DO_UPWELLING ) THEN
c            if ( do_write_screen) write(*,*)'wf up',ibeam,layer_to_vary
               CALL VLIDORT_UPUSER_ATMOSWF
     I         ( DO_INCLUDE_SURFACE,
     I           DO_INCLUDE_THERMEMISS,
     I           DO_INCLUDE_MVOUTPUT,
     I           DO_REFLECTED_DIRECTBEAM(IBEAM),
     I           SURFACE_FACTOR,      FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IBEAM,
     I           VARIATION_INDEX,     N_TOTALCOLUMN_WFS,
     I           L_BOA_LAMBERTIAN_SOURCE )
            ENDIF

            IF ( DO_DNWELLING ) THEN
c           if ( do_write_screen) write(*,*)'wf dn',ibeam,layer_to_vary
              CALL VLIDORT_DNUSER_ATMOSWF
     I         ( DO_INCLUDE_THERMEMISS,
     I           FLUX_MULTIPLIER,
     I           FOURIER_COMPONENT,   IBEAM,
     I           VARIATION_INDEX,     N_TOTALCOLUMN_WFS )
            ENDIF

            IF ( DO_INCLUDE_MVOUTPUT .OR. DO_QUAD_OUTPUT ) THEN
              CALL VLIDORT_L_INTEGRATED_OUTPUT
     I            ( DO_INCLUDE_MVOUTPUT,
     I              DO_REFLECTED_DIRECTBEAM(IBEAM),
     I              DO_INCLUDE_THERMEMISS,
     I              FLUX_MULTIPLIER,
     I              IBEAM, VARIATION_INDEX, N_TOTALCOLUMN_WFS )
            ENDIF

C  End atmospheric column weighting functions

          ENDIF

C  Step 5. Surface Reflectance weighting functions
C  -----------------------------------------------

          IF ( DO_SURFACE_LINEARIZATION ) THEN

C  initialise weighting function count

            WF_INDEX   = 1
            BRDF_INDEX = 1

C  Only do this if there is surface reflectance !

            IF ( DO_INCLUDE_SURFACE ) THEN

C  Lambertian albedo weighting function

              CALL VLIDORT_ALBEDO_WFS
     I           (  DO_REFLECTED_DIRECTBEAM(IBEAM),
     I              DO_INCLUDE_SURFEMISS,
     I              DO_INCLUDE_MVOUTPUT,
     I              BVP_REGULAR_FLAG(FOURIER_COMPONENT),
     I              FOURIER_COMPONENT, IBEAM,
     I              SURFACE_FACTOR,
     I              FLUX_MULTIPLIER,
     I              BRDF_INDEX, WF_INDEX,
     I              LS_BVP_LAMBERTIAN_SURFACE,
     I              LS_BOA_LAMBERTIAN_SOURCE,
     O              STATUS_SUB )

              IF ( STATUS_SUB .NE. VLIDORT_SUCCESS ) THEN
                MAIL = 'Error in module VLIDORT_ALBEDO_WFS'
                TRACE= 'Call #10 in VLIDORT_L_FOURIER_LAMBERTIAN'
                STATUS = VLIDORT_SERIOUS
                CALL VLIDORT_ERROR_TRACE ( MAIL, TRACE, STATUS )
                RETURN
              ENDIF

            ENDIF

C  end of albedo weighting functions

          ENDIF

C  Continuation point for avoiding weighting functions

 4000     CONTINUE

C  End loop over beam solutions

        END IF
      END DO

C  debug write

      IF ( DO_DEBUG_WRITE ) THEN
        write(54,'(a,I3,a,100I3)')
     &     'Fourier ',FOURIER_COMPONENT,
     &   ' : # complex evalues by layer: ',
     &       (K_COMPLEX(LAYER),LAYER=1,NLAYERS)
      ENDIF

C  ######
C  finish
C  ######

      RETURN
      END


      SUBROUTINE CNMN00 (X,VLB,VUB,G,SCAL,DF,A,S,G1,G2,B,C,ISC,IC,MS1,N1
     1,N2,N3,N4,N5)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /CNMN1/ DELFUN,DABFUN,FDCH,FDCHM,CT,CTMIN,CTL,CTLMIN,ALPHAX
     1,ABOBJ1,THETA,OBJ,NDV,NCON,NSIDE,IPRINT,NFDG,NSCAL,LINOBJ,ITMAX,IT
     2RM,ICNDIR,IGOTO,NAC,INFO,INFOG,ITER,NFEASCT
      COMMON /OUTPUT/ IOUT
C
C    NFEASCT ADDED TO COMMON BLOCK BY KCYOUNG ON 4/14/92 TO ALLOW MORE
C    THAN 10 ITERATION ATTEMPTS.  NFEASCT BECOMES AN INPUT VALUE
C
      DIMENSION X(N1), VLB(N1), VUB(N1), G(N2), SCAL(N1), DF(N1), A(N1,N
     13), S(N1), G1(N2), G2(N2), B(N3,N3), C(N4), ISC(N2), IC(N3), MS1(N
     25)
      COMMON /CONSAV/ DM1,DM2,DM3,DM4,DM5,DM6,DM7,DM8,DM9,DM10,DM11,DM12
     1,DCT,DCTL,PHI,ABOBJ,CTA,CTAM,CTBM,OBJ1,SLOPE,DX,DX1,FI,XI,DFTDF1,A
     2LP,FFF,A1,A2,A3,A4,F1,F2,F3,F4,CV1,CV2,CV3,CV4,APP,ALPCA,ALPFES,AL
     3PLN,ALPMIN,ALPNC,ALPSAV,ALPSID,ALPTOT,RSPACE,IDM1,IDM2,IDM3,JDIR,I
     4OBJ,KOBJ,KCOUNT,NCAL(2),NFEAS,MSCAL,NCOBJ,NVC,KOUNT,ICOUNT,IGOOD1,
     5IGOOD2,IGOOD3,IGOOD4,IBEST,III,NLNC,JGOTO,ISPACE(2)
C     ROUTINE TO SOLVE CONSTRAINED OR UNCONSTRAINED FUNCTION
C     MINIMIZATION.
C     BY G. N. VANDERPLAATS                          APRIL, 1972.
C     * * * * * * * * * * *   JUNE, 1979 VERSION   * * * * * * * * * * *
C     NASA-AMES RESEARCH CENTER, MOFFETT FIELD, CALIF.
C     REFERENCE;  CONMIN - A FORTRAN PROGRAM FOR CONSTRAINED FUNCTION
C         MINIMIZATION:  USER'S MANUAL,  BY G. N. VANDERPLAATS,
C         NASA TM X-62,282, AUGUST, 1973.
C     STORAGE REQUIREMENTS:
C         PROGRAM - 7000 DECIMAL WORDS (CDC COMPUTER)
C         ARRAYS  - APPROX. 2*(NDV**2)+26*NDV+4*NCON,
C               WHERE N3 = NDV+2.
C     RE-SCALE VARIABLES IF REQUIRED.
      IF (NSCAL.EQ.0.OR.IGOTO.EQ.0) GO TO 20
      DO 10 I=1,NDV
10    X(I)=C(I)
20    CONTINUE
C     CONSTANTS.
      NDV1=NDV+1
      NDV2=NDV+2
      IF (IGOTO.EQ.0) GO TO 40
C     ------------------------------------------------------------------
C                     CHECK FOR UNBOUNDED SOLUTION
C     ------------------------------------------------------------------
C     STOP IF OBJ IS LESS THAN -1.0E+20
      IF (OBJ.GT.-1.0E+20) GO TO 30
      WRITE (IOUT,980)
      GO TO 810
30    CONTINUE
      GO TO (160,390,380,670,690),IGOTO
C     ------------------------------------------------------------------
C                      SAVE INPUT CONTROL PARAMETERS
C     ------------------------------------------------------------------
40    CONTINUE
      IF (IPRINT.GT.0) WRITE (IOUT,1220)
      IF (LINOBJ.EQ.0.OR.(NCON.GT.0.OR.NSIDE.GT.0)) GO TO 50
C     TOTALLY UNCONSTRAINED FUNCTION WITH LINEAR OBJECTIVE.
C     SOLUTION IS UNBOUNDED.
      WRITE (IOUT,970) LINOBJ,NCON,NSIDE
      RETURN
50    CONTINUE
      IDM1=ITRM
      IDM2=ITMAX
      IDM3=ICNDIR
      DM1=DELFUN
      DM2=DABFUN
      DM3=CT
      DM4=CTMIN
      DM5=CTL
      DM6=CTLMIN
      DM7=THETA
      DM8=PHI
      DM9=FDCH
      DM10=FDCHM
      DM11=ABOBJ1
      DM12=ALPHAX
C     ------------------------------------------------------------------
C                                DEFAULTS
C     ------------------------------------------------------------------
      IF (ITRM.LE.0) ITRM=3
      IF (ITMAX.LE.0) ITMAX=20
      NDV1=NDV+1
      IF (ICNDIR.EQ.0) ICNDIR=NDV1
      IF (DELFUN.LE.0.) DELFUN=.0001
      CT=-ABS(CT)
      IF (CT.GE.0.) CT=-.1
      CTMIN=ABS(CTMIN)
      IF (CTMIN.LE.0.) CTMIN=.004
      CTL=-ABS(CTL)
      IF (CTL.GE.0.) CTL=-0.01
      CTLMIN=ABS(CTLMIN)
      IF (CTLMIN.LE.0.) CTLMIN=.001
      IF (THETA.LE.0.) THETA=1.
      IF (ABOBJ1.LE.0.) ABOBJ1=.1
      IF (ALPHAX.LE.0.) ALPHAX=.1
      IF (FDCH.LE.0.) FDCH=.01
      IF (FDCHM.LE.0.) FDCHM=.01
C     ------------------------------------------------------------------
C                     INITIALIZE INTERNAL PARAMETERS
C     ------------------------------------------------------------------
      INFOG=0
      ITER=0
      JDIR=0
      IOBJ=0
      KOBJ=0
      NDV2=NDV+2
      KCOUNT=0
      NCAL(1)=0
      NCAL(2)=0
      NAC=0
      NFEAS=0
      MSCAL=NSCAL
      CT1=ITRM
      CT1=1./CT1
      DCT=(CTMIN/ABS(CT))**CT1
      DCTL=(CTLMIN/ABS(CTL))**CT1
      PHI=5.
      ABOBJ=ABOBJ1
      NCOBJ=0
      CTAM=ABS(CTMIN)
      CTBM=ABS(CTLMIN)
C     CALCULATE NUMBER OF LINEAR CONSTRAINTS, NLNC.
      NLNC=0
      IF (NCON.EQ.0) GO TO 70
      DO 60 I=1,NCON
      IF (ISC(I).GT.0) NLNC=NLNC+1
60    CONTINUE
70    CONTINUE
C     ------------------------------------------------------------------
C          CHECK TO BE SURE THAT SIDE CONSTRAINTS ARE SATISFIED
C     ------------------------------------------------------------------
      IF (NSIDE.EQ.0) GO TO 110
      DO 100 I=1,NDV
      IF (VLB(I).LE.VUB(I)) GO TO 80
      XX=.5*(VLB(I)+VUB(I))
      X(I)=XX
      VLB(I)=XX
      VUB(I)=XX
      WRITE (IOUT,1120) I
80    CONTINUE
      XX=X(I)-VLB(I)
      IF (XX.GE.0.) GO TO 90
C     LOWER BOUND VIOLATED.
      WRITE (IOUT,1130) X(I),VLB(I),I
      X(I)=VLB(I)
      GO TO 100
90    CONTINUE
      XX=VUB(I)-X(I)
      IF (XX.GE.0.) GO TO 100
      WRITE (IOUT,1140) X(I),VUB(I),I
      X(I)=VUB(I)
100   CONTINUE
110   CONTINUE
C     ------------------------------------------------------------------
C                        INITIALIZE SCALING VECTOR, SCAL
C     ------------------------------------------------------------------
      IF (NSCAL.EQ.0) GO TO 150
      IF (NSCAL.LT.0) GO TO 130
      DO 120 I=1,NDV
120   SCAL(I)=1.
      GO TO 150
130   CONTINUE
      DO 140 I=1,NDV
      SI=ABS(SCAL(I))
      IF (SI.LT.1.0E-20) SI=1.0E-5
      SCAL(I)=SI
      SI=1./SI
      X(I)=X(I)*SI
      IF (NSIDE.EQ.0) GO TO 140
      VLB(I)=VLB(I)*SI
      VUB(I)=VUB(I)*SI
140   CONTINUE
150   CONTINUE
C     ------------------------------------------------------------------
C     ***** CALCULATE INITIAL FUNCTION AND CONSTRAINT VALUES  *****
C     ------------------------------------------------------------------
      INFO=1
      NCAL(1)=1
      IGOTO=1
      GO TO 950
160   CONTINUE
      OBJ1=OBJ
      IF (DABFUN.LE.0.) DABFUN=.001*ABS(OBJ)
      IF (DABFUN.LT.1.0E-10) DABFUN=1.0E-10
      IF (IPRINT.LE.0) GO TO 270
C     ------------------------------------------------------------------
C                    PRINT INITIAL DESIGN INFORMATION
C     ------------------------------------------------------------------
      IF (IPRINT.LE.1) GO TO 230
      IF (NSIDE.EQ.0.AND.NCON.EQ.0) WRITE (IOUT,1290)
      IF (NSIDE.NE.0.OR.NCON.GT.0) WRITE (IOUT,1230)
      WRITE (IOUT,1240) IPRINT,NDV,ITMAX,NCON,NSIDE,ICNDIR,NSCAL,NFDG
     1,LINOBJ,ITRM,N1,N2,N3,N4,N5
      WRITE (IOUT,1260) CT,CTMIN,CTL,CTLMIN,THETA,PHI,DELFUN,DABFUN
      WRITE (IOUT,1250) FDCH,FDCHM,ALPHAX,ABOBJ1
      IF (NSIDE.EQ.0) GO TO 190
      WRITE (IOUT,1270)
      DO 170 I=1,NDV,6
      M1=MIN0(NDV,I+5)
170   WRITE (IOUT,1010) I,(VLB(J),J=I,M1)
      WRITE (IOUT,1280)
      DO 180 I=1,NDV,6
      M1=MIN0(NDV,I+5)
180   WRITE (IOUT,1010) I,(VUB(J),J=I,M1)
190   CONTINUE
      IF (NSCAL.GE.0) GO TO 200
      WRITE (IOUT,1300)
      WRITE (IOUT,1460) (SCAL(I),I=1,NDV)
200   CONTINUE
      IF (NCON.EQ.0) GO TO 230
      IF (NLNC.EQ.0.OR.NLNC.EQ.NCON) GO TO 220
      WRITE (IOUT,1020)
      DO 210 I=1,NCON,15
      M1=MIN0(NCON,I+14)
210   WRITE (IOUT,1030) I,(ISC(J),J=I,M1)
      GO TO 230
220   IF (NLNC.EQ.NCON) WRITE (IOUT,1040)
      IF (NLNC.EQ.0) WRITE (IOUT,1050)
230   CONTINUE
      WRITE (IOUT,1440) OBJ
      WRITE (IOUT,1450)
      DO 240 I=1,NDV
      X1=1.
      IF (NSCAL.NE.0) X1=SCAL(I)
240   G1(I)=X(I)*X1
      DO 250 I=1,NDV,6
      M1=MIN0(NDV,I+5)
250   WRITE (IOUT,1010) I,(G1(J),J=I,M1)
      IF (NCON.EQ.0) GO TO 270
      WRITE (IOUT,1470)
      DO 260 I=1,NCON,6
      M1=MIN0(NCON,I+5)
260   WRITE (IOUT,1010) I,(G(J),J=I,M1)
270   CONTINUE
      IF (IPRINT.GT.1) WRITE (IOUT,1360)
C     ------------------------------------------------------------------
C     ********************  BEGIN MINIMIZATION  ************************
C     ------------------------------------------------------------------
280   CONTINUE
      ITER=ITER+1
      IF (ABOBJ1.LT..0001) ABOBJ1=.0001
      IF (ABOBJ1.GT..2) ABOBJ1=.2
      IF (ALPHAX.GT.1.) ALPHAX=1.
      IF (ALPHAX.LT..001) ALPHAX=.001
C
C  THE FOLLOWING TWO LINES OF CODE WERE COMMENTED OUT ON 3/5/81
C
C     NFEAS=NFEAS+1
C     IF (NFEAS.GT.10) GO TO 810
      IF (IPRINT.GT.2) WRITE (IOUT,1310) ITER
      IF (IPRINT.GT.3.AND.NCON.GT.0) WRITE (IOUT,1320) CT,CTL,PHI
      CTA=ABS(CT)
      IF (NCOBJ.EQ.0) GO TO 340
C     ------------------------------------------------------------------
C     NO MOVE ON LAST ITERATION.  DELETE CONSTRAINTS THAT ARE NO
C     LONGER ACTIVE.
C     ------------------------------------------------------------------
      NNAC=NAC
      DO 290 I=1,NNAC
      IF (IC(I).GT.NCON) NAC=NAC-1
290   CONTINUE
      IF (NAC.LE.0) GO TO 420
      NNAC=NAC
      DO 330 I=1,NNAC
300   NIC=IC(I)
      CT1=CT
      IF (ISC(NIC).GT.0) CT1=CTL
      IF (G(NIC).GT.CT1) GO TO 330
      NAC=NAC-1
      IF (I.GT.NAC) GO TO 420
      DO 320 K=I,NAC
      II=K+1
      DO 310 J=1,NDV2
310   A(J,K)=A(J,II)
320   IC(K)=IC(II)
      GO TO 300
330   CONTINUE
      GO TO 420
340   CONTINUE
      IF (MSCAL.LT.NSCAL.OR.NSCAL.EQ.0) GO TO 360
      IF (NSCAL.LT.0.AND.KCOUNT.LT.ICNDIR) GO TO 360
      MSCAL=0
      KCOUNT=0
C     ------------------------------------------------------------------
C                          SCALE VARIABLES
C     ------------------------------------------------------------------
      DO 350 I=1,NDV
      SI=SCAL(I)
      XI=SI*X(I)
      SIB=SI
      IF (NSCAL.GT.0) SI=ABS(XI)
      IF (SI.LT.1.0E-10) GO TO 350
      SCAL(I)=SI
      SI=1./SI
      X(I)=XI*SI
      IF (NSIDE.EQ.0) GO TO 350
      VLB(I)=SIB*SI*VLB(I)
      VUB(I)=SIB*SI*VUB(I)
350   CONTINUE
      IF (IPRINT.LT.4.OR.(NSCAL.LT.0.AND.ITER.GT.1)) GO TO 360
      WRITE (IOUT,1330)
      WRITE (IOUT,1460) (SCAL(I),I=1,NDV)
360   CONTINUE
      MSCAL=MSCAL+1
      NAC=0
C     ------------------------------------------------------------------
C          OBTAIN GRADIENTS OF OBJECTIVE AND ACTIVE CONSTRAINTS
C     ------------------------------------------------------------------
      INFO=2
      NCAL(2)=NCAL(2)+1
      IF (NFDG.NE.1) GO TO 370
      IGOTO=2
      GO TO 950
370   CONTINUE
      JGOTO=0
380   CONTINUE
      CALL CNMN01 (JGOTO,X,DF,G,ISC,IC,A,G1,VLB,VUB,SCAL,C,NCAL,DX,DX1
     1,FI,XI,III,N1,N2,N3,N4)
      IGOTO=3
      IF (JGOTO.GT.0) GO TO 950
390   CONTINUE
      INFO=1
      IF (NAC.GE.N3) GO TO 810
      IF (NSCAL.EQ.0.OR.NFDG.EQ.0) GO TO 420
C     ------------------------------------------------------------------
C                              SCALE GRADIENTS
C     ------------------------------------------------------------------
C     SCALE GRADIENT OF OBJECTIVE FUNCTION.
      DO 400 I=1,NDV
400   DF(I)=DF(I)*SCAL(I)
      IF (NFDG.EQ.2.OR.NAC.EQ.0) GO TO 420
C     SCALE GRADIENTS OF ACTIVE CONSTRAINTS.
      DO 410 J=1,NDV
      SCJ=SCAL(J)
      DO 410 I=1,NAC
410   A(J,I)=A(J,I)*SCJ
420   CONTINUE
      IF (IPRINT.LT.3.OR.NCON.EQ.0) GO TO 470
C     ------------------------------------------------------------------
C                                   PRINT
C     ------------------------------------------------------------------
C     PRINT ACTIVE AND VIOLATED CONSTRAINT NUMBERS.
      M1=0
      M2=N3
      IF (NAC.EQ.0) GO TO 450
      DO 440 I=1,NAC
      J=IC(I)
      IF (J.GT.NCON) GO TO 440
      GI=G(J)
      C1=CTAM
      IF (ISC(J).GT.0) C1=CTBM
      GI=GI-C1
      IF (GI.GT.0.) GO TO 430
C     ACTIVE CONSTRAINT.
      M1=M1+1
      MS1(M1)=J
      GO TO 440
430   M2=M2+1
C     VIOLATED CONSTRAINT.
      MS1(M2)=J
440   CONTINUE
450   M3=M2-N3
      WRITE (IOUT,1060) M1
      IF (M1.EQ.0) GO TO 460
      WRITE (IOUT,1070)
      WRITE (IOUT,1480) (MS1(I),I=1,M1)
460   WRITE (IOUT,1080) M3
      IF (M3.EQ.0) GO TO 470
      WRITE (IOUT,1070)
      M3=N3+1
      WRITE (IOUT,1480) (MS1(I),I=M3,M2)
470   CONTINUE
C     ------------------------------------------------------------------
C            CALCULATE GRADIENTS OF ACTIVE SIDE CONSTRAINTS
C     ------------------------------------------------------------------
      IF (NSIDE.EQ.0) GO TO 530
      MCN1=NCON
      M1=0
      DO 510 I=1,NDV
C     LOWER BOUND.
      XI=X(I)
      XID=VLB(I)
      X12=ABS(XID)
      IF (X12.LT.1.) X12=1.
      GI=(XID-XI)/X12
      IF (GI.LT.-1.0E-6) GO TO 490
      M1=M1+1
      MS1(M1)=-I
      NAC=NAC+1
      IF (NAC.GE.N3) GO TO 810
      MCN1=MCN1+1
      DO 480 J=1,NDV
480   A(J,NAC)=0.
      A(I,NAC)=-1.
      IC(NAC)=MCN1
      G(MCN1)=GI
      ISC(MCN1)=1
C     UPPER BOUND.
490   XID=VUB(I)
      X12=ABS(XID)
      IF (X12.LT.1.) X12=1.
      GI=(XI-XID)/X12
      IF (GI.LT.-1.0E-6) GO TO 510
      M1=M1+1
      MS1(M1)=I
      NAC=NAC+1
      IF (NAC.GE.N3) GO TO 810
      MCN1=MCN1+1
      DO 500 J=1,NDV
500   A(J,NAC)=0.
      A(I,NAC)=1.
      IC(NAC)=MCN1
      G(MCN1)=GI
      ISC(MCN1)=1
510   CONTINUE
C     ------------------------------------------------------------------
C                                  PRINT
C     ------------------------------------------------------------------
C     PRINT ACTIVE SIDE CONSTRAINT NUMBERS.
      IF (IPRINT.LT.3) GO TO 530
      WRITE (IOUT,1090) M1
      IF (M1.EQ.0) GO TO 530
      WRITE (IOUT,1100)
      WRITE(6,1480) (MS1(J),J=1,M1)
530   CONTINUE
C     PRINT GRADIENTS OF ACTIVE AND VIOLATED CONSTRAINTS.
      IF (IPRINT.LT.4) GO TO 570
      WRITE (IOUT,1340)
      DO 540 I=1,NDV,6
      M1=MIN0(NDV,I+5)
540   WRITE (IOUT,1010) I,(DF(J),J=I,M1)
      IF (NAC.EQ.0) GO TO 570
      WRITE (IOUT,1350)
      DO 560 I=1,NAC
      M1=IC(I)
      M2=M1-NCON
      M3=0
      IF (M2.GT.0) M3=IABS(MS1(M2))
      IF (M2.LE.0) WRITE (IOUT,990) M1
      IF (M2.GT.0) WRITE (IOUT,1000) M3
      DO 550 K=1,NDV,6
      M1=MIN0(NDV,K+5)
550   WRITE (IOUT,1010) K,(A(J,I),J=K,M1)
560   WRITE (IOUT,1360)
570   CONTINUE
C     ------------------------------------------------------------------
C     ******************  DETERMINE SEARCH DIRECTION *******************
C     ------------------------------------------------------------------
      ALP=1.0E+20
      IF (NAC.GT.0) GO TO 580
C     ------------------------------------------------------------------
C                        UNCONSTRAINED FUNCTION
C     ------------------------------------------------------------------
C     FIND DIRECTION OF STEEPEST DESCENT OR CONJUGATE DIRECTION.
C
C  S. N. 575 ADDED ON 2/25/81
C
 575  NVC=0
      NFEAS=0
      KCOUNT=KCOUNT+1
C     IF KCOUNT.GT.ICNDIR  RESTART CONJUGATE DIRECTION ALGORITHM.
      IF (KCOUNT.GT.ICNDIR.OR.IOBJ.EQ.2) KCOUNT=1
      IF (KCOUNT.EQ.1) JDIR=0
C     IF JDIR = 0 FIND DIRECTION OF STEEPEST DESCENT.
      CALL CNMN02 (JDIR,SLOPE,DFTDF1,DF,S,N1)
      GO TO 630
580   CONTINUE
C     ------------------------------------------------------------------
C                          CONSTRAINED FUNCTION
C     ------------------------------------------------------------------
C     FIND USABLE-FEASIBLE DIRECTION.
      KCOUNT=0
      JDIR=0
      PHI=10.*PHI
      IF (PHI.GT.1000.) PHI=1000.
C
C  THE FOLLOWING LINE OF CODE WAS COMMENTED OUT ON 3/5/81
C
C     IF (NFEAS.EQ.1) PHI=5.
C     CALCULATE DIRECTION, S.
      CALL CNMN05 (G,DF,A,S,B,C,SLOPE,PHI,ISC,IC,MS1,NVC,N1,N2,N3,N4,N5)
C
C  THE FOLLOWING LINE WAS ADDED ON 2/25/81
C
      IF(NAC.EQ.0) GO TO 575
C
C  THE FOLLOWING FIVE LINES WERE COMMENTED OUT ON 3/5/81
C  REASON : THEY WERE NOT IN G. VANDERPLAATS LISTING
C
C     IF THIS DESIGN IS FEASIBLE AND LAST ITERATION WAS INFEASIBLE,
C     SET ABOBJ1=.05 (5 PERCENT).
C     IF (NVC.EQ.0.AND.NFEAS.GT.1) ABOBJ1=.05
C     IF (NVC.EQ.0) NFEAS=0
      IF (IPRINT.LT.3) GO TO 600
      WRITE (IOUT,1370)
      DO 590 I=1,NAC,6
      M1=MIN0(NAC,I+5)
590   WRITE (IOUT,1010) I,(A(NDV1,J),J=I,M1)
      WRITE (IOUT,1210) S(NDV1)
600   CONTINUE
C     ------------------------------------------------------------------
C     ****************** ONE-DIMENSIONAL SEARCH ************************
C     ------------------------------------------------------------------
      IF (S(NDV1).LT.1.0E-6.AND.NVC.EQ.0) GO TO 710
C     ------------------------------------------------------------------
C                 FIND ALPHA TO OBTAIN A FEASIBLE DESIGN
C     ------------------------------------------------------------------
      IF (NVC.EQ.0) GO TO 630
      ALP=-1.
      DO 620 I=1,NAC
      NCI=IC(I)
      C1=G(NCI)
      CTC=CTAM
      IF (ISC(NCI).GT.0) CTC=CTBM
      IF (C1.LE.CTC) GO TO 620
      ALP1=0.
      DO 610 J=1,NDV
610   ALP1=ALP1+S(J)*A(J,I)
      ALP1=ALP1*A(NDV2,I)
      IF (ABS(ALP1).LT.1.0E-20) GO TO 620
      ALP1=-C1/ALP1
      IF (ALP1.GT.ALP) ALP=ALP1
620   CONTINUE
630   CONTINUE
C     ------------------------------------------------------------------
C                       LIMIT CHANCE TO ABOBJ1*OBJ
C     ------------------------------------------------------------------
      ALP1=1.0E+20
      SI=ABS(OBJ)
      IF (SI.LT..01) SI=.01
      IF (ABS(SLOPE).GT.1.0E-20) ALP1=ABOBJ1*SI/SLOPE
      ALP1=ABS(ALP1)
      IF (NVC.GT.0) ALP1=10.*ALP1
      IF (ALP1.LT.ALP) ALP=ALP1
C     ------------------------------------------------------------------
C                   LIMIT CHANGE IN VARIABLE TO ALPHAX
C     ------------------------------------------------------------------
      ALP11=1.0E+20
      DO 640 I=1,NDV
      SI=ABS(S(I))
      XI=ABS(X(I))
      IF (SI.LT.1.0E-10.OR.XI.LT.0.1) GO TO 640
      ALP1=ALPHAX*XI/SI
      IF (ALP1.LT.ALP11) ALP11=ALP1
640   CONTINUE
      IF (NVC.GT.0) ALP11=10.*ALP11
      IF (ALP11.LT.ALP) ALP=ALP11
      IF (ALP.GT.1.0E+20) ALP=1.0E+20
      IF (ALP.LE.1.0E-20) ALP=1.0E-20
      IF (IPRINT.LT.3) GO TO 660
      WRITE (IOUT,1380)
      DO 650 I=1,NDV,6
      M1=MIN0(NDV,I+5)
650   WRITE (IOUT,1010) I,(S(J),J=I,M1)
      WRITE (IOUT,1110) SLOPE,ALP
660   CONTINUE
      IF (NCON.GT.0.OR.NSIDE.GT.0) GO TO 680
C     ------------------------------------------------------------------
C           DO ONE-DIMENSIONAL SEARCH FOR UNCONSTRAINED FUNCTION
C     ------------------------------------------------------------------
      JGOTO=0
670   CONTINUE
      CALL CNMN03 (X,S,SLOPE,ALP,FFF,A1,A2,A3,A4,F1,F2,F3,F4,APP,N1
     1,NCAL,KOUNT,JGOTO)
      IGOTO=4
      IF (JGOTO.GT.0) GO TO 950
      JDIR=1
C     PROCEED TO CONVERGENCE CHECK.
      GO TO 700
C     ------------------------------------------------------------------
C       SOLVE ONE-DIMENSIONAL SEARCH PROBLEM FOR CONSTRAINED FUNCTION
C     ------------------------------------------------------------------
680   CONTINUE
      JGOTO=0
690   CONTINUE
      CALL CNMN06 (X,VLB,VUB,G,SCAL,DF,S,G1,G2,CTAM,CTBM,SLOPE,ALP,A2,A3
     1,A4,F1,F2,F3,CV1,CV2,CV3,CV4,ALPCA,ALPFES,ALPLN,ALPMIN,ALPNC,ALPSA
     2V,ALPSID,ALPTOT,ISC,N1,N2,NCAL,NVC,ICOUNT,IGOOD1,IGOOD2,IGOOD3,IGO
     3OD4,IBEST,III,NLNC,JGOTO)
      IGOTO=5
      IF (JGOTO.GT.0) GO TO 950
      IF (NAC.EQ.0) JDIR=1
C     ------------------------------------------------------------------
C     *******************     UPDATE ALPHAX   **************************
C     ------------------------------------------------------------------
700   CONTINUE
710   CONTINUE
      IF (ALP.GT.1.0E+19) ALP=0.
C     UPDATE ALPHAX TO BE AVERAGE OF MAXIMUM CHANGE IN X(I)
C     AND ALHPAX.
      ALP11=0.
      DO 720 I=1,NDV
      SI=ABS(S(I))
      XI=ABS(X(I))
      IF (XI.LT.1.0E-10) GO TO 720
      ALP1=ALP*SI/XI
      IF (ALP1.GT.ALP11) ALP11=ALP1
720   CONTINUE
      ALP11=.5*(ALP11+ALPHAX)
      ALP12=5.*ALPHAX
      IF (ALP11.GT.ALP12) ALP11=ALP12
      ALPHAX=ALP11
      NCOBJ=NCOBJ+1
C     ABSOLUTE CHANGE IN OBJECTIVE.
      OBJD=OBJ1-OBJ
      OBJB=ABS(OBJD)
      IF (OBJB.LT.1.0E-10) OBJB=0.
      IF (NAC.EQ.0.OR.OBJB.GT.0.) NCOBJ=0
      IF (NCOBJ.GT.1) NCOBJ=0
C     ------------------------------------------------------------------
C                                  PRINT
C     ------------------------------------------------------------------
C     PRINT MOVE PARAMETER, NEW X-VECTOR AND CONSTRAINTS.
      IF (IPRINT.LT.3) GO TO 730
      WRITE (IOUT,1390) ALP
730   IF (IPRINT.LT.2) GO TO 800
      IF (OBJB.GT.0.) GO TO 740
      IF (IPRINT.EQ.2) WRITE (IOUT,1400) ITER,OBJ
      IF (IPRINT.GT.2) WRITE (IOUT,1410) OBJ
      GO TO 760
740   IF (IPRINT.EQ.2) GO TO 750
      WRITE (IOUT,1420) OBJ
      GO TO 760
750   WRITE (IOUT,1430) ITER,OBJ
760   WRITE (IOUT,1450)
      DO 770 I=1,NDV
      FF1=1.
      IF (NSCAL.NE.0) FF1=SCAL(I)
770   G1(I)=FF1*X(I)
      DO 780 I=1,NDV,6
      M1=MIN0(NDV,I+5)
780   WRITE (IOUT,1010) I,(G1(J),J=I,M1)
      IF (NCON.EQ.0) GO TO 800
      WRITE (IOUT,1470)
      DO 790 I=1,NCON,6
      M1=MIN0(NCON,I+5)
790   WRITE (IOUT,1010) I,(G(J),J=I,M1)
800   CONTINUE
C
C  THE FOLLOWING CODE WAS ADDED ON 3/5/81
C
C  IT HAD NOT BEEN REPORTED AS A FIX TO MAOB
C  BUT WAS SENT TO JEFF STROUD A YEAR AGO
C  SEE OTHER COMMENTS IN CONMIN SUBROUTINE FOR DELETIONS OF CODE
C  ON 3/5/81 PERTAINING TO THIS FIX
C
C
C                   CHECK FEASIBILITY
C
      IF(NCON.LE.0) GO TO 808
      NFEASCT=10
      DO 804 I=1,NCON
      C1=CTAM
      IF(ISC(I).GT.0) C1=CTBM
      IF(G(I).LE.C1) GO TO 804
      NFEAS=NFEAS+1
      GO TO 806
 804  CONTINUE
      IF(NFEAS.GT.0) ABOBJ1=.05
      NFEAS=0
      PHI=5.
 806  IF(NFEAS.GE.NFEASCT) GO TO 810
 808  CONTINUE
C
C  END OF INSERTED FIX
C
C     ------------------------------------------------------------------
C                          CHECK CONVERGENCE
C     ------------------------------------------------------------------
C     STOP IF ITER EQUALS ITMAX.
      IF (ITER.GE.ITMAX) GO TO 810
C     ------------------------------------------------------------------
C                     ABSOLUTE CHANGE IN OBJECTIVE
C     ------------------------------------------------------------------
      OBJB=ABS(OBJD)
      KOBJ=KOBJ+1
      IF (OBJB.GE.DABFUN.OR.NFEAS.GT.0) KOBJ=0
C     ------------------------------------------------------------------
C                     RELATIVE CHANGE IN OBJECTIVE
C     ------------------------------------------------------------------
      IF (ABS(OBJ1).GT.1.0E-10) OBJD=OBJD/ABS(OBJ1)
      ABOBJ1=.5*(ABS(ABOBJ)+ABS(OBJD))
      ABOBJ=ABS(OBJD)
      IOBJ=IOBJ+1
      IF (NVC.GT.0.OR.OBJD.GE.DELFUN) IOBJ=0
      IF (IOBJ.GE.ITRM.OR.KOBJ.GE.ITRM) GO TO 810
      OBJ1=OBJ
C     ------------------------------------------------------------------
C           REDUCE CT IF OBJECTIVE FUNCTION IS CHANGING SLOWLY
C     ------------------------------------------------------------------
      IF (IOBJ.LT.1.OR.NAC.EQ.0) GO TO 280
      CT=DCT*CT
      CTL=CTL*DCTL
      IF (ABS(CT).LT.CTMIN) CT=-CTMIN
      IF (ABS(CTL).LT.CTLMIN) CTL=-CTLMIN
      GO TO 280
810   CONTINUE
      IF (NAC.GE.N3) WRITE (IOUT,1490)
C     ------------------------------------------------------------------
C     ****************  FINAL FUNCTION INFORMATION  ********************
C     ------------------------------------------------------------------
      IF (NSCAL.EQ.0) GO TO 830
C     UN-SCALE THE DESIGN VARIABLES.
      DO 820 I=1,NDV
      XI=SCAL(I)
      IF (NSIDE.EQ.0) GO TO 820
      VLB(I)=XI*VLB(I)
      VUB(I)=XI*VUB(I)
820   X(I)=XI*X(I)
C     ------------------------------------------------------------------
C                           PRINT FINAL RESULTS
C     ------------------------------------------------------------------
830   IF (IPRINT.EQ.0.OR.NAC.GE.N3) GO TO 940
      WRITE (IOUT,1500)
      WRITE (IOUT,1420) OBJ
      WRITE (IOUT,1450)
      DO 840 I=1,NDV,6
      M1=MIN0(NDV,I+5)
840   WRITE (IOUT,1010) I,(X(J),J=I,M1)
      IF (NCON.EQ.0) GO TO 900
      WRITE (IOUT,1470)
      DO 850 I=1,NCON,6
      M1=MIN0(NCON,I+5)
850   WRITE (IOUT,1010) I,(G(J),J=I,M1)
C     DETERMINE WHICH CONSTRAINTS ARE ACTIVE AND PRINT.
      NAC=0
      NVC=0
      DO 870 I=1,NCON
      CTA=CTAM
      IF (ISC(I).GT.0) CTA=CTBM
      GI=G(I)
      IF (GI.GT.CTA) GO TO 860
      IF (GI.LT.CT.AND.ISC(I).EQ.0) GO TO 870
      IF (GI.LT.CTL.AND.ISC(I).GT.0) GO TO 870
      NAC=NAC+1
      IC(NAC)=I
      GO TO 870
860   NVC=NVC+1
      MS1(NVC)=I
870   CONTINUE
      WRITE (IOUT,1060) NAC
      IF (NAC.EQ.0) GO TO 880
      WRITE (IOUT,1070)
      WRITE (IOUT,1480) (IC(J),J=1,NAC)
880   WRITE (IOUT,1080) NVC
      IF (NVC.EQ.0) GO TO 890
      WRITE (IOUT,1070)
      WRITE (IOUT,1480) (MS1(J),J=1,NVC)
890   CONTINUE
900   CONTINUE
      IF (NSIDE.EQ.0) GO TO 930
C     DETERMINE WHICH SIDE CONSTRAINTS ARE ACTIVE AND PRINT.
      NAC=0
      DO 920 I=1,NDV
      XI=X(I)
      XID=VLB(I)
      X12=ABS(XID)
      IF (X12.LT.1.) X12=1.
      GI=(XID-XI)/X12
      IF (GI.LT.-1.0E-6) GO TO 910
      NAC=NAC+1
      MS1(NAC)=-I
910   XID=VUB(I)
      X12=ABS(XID)
      IF (X12.LT.1.) X12=1.
      GI=(XI-XID)/X12
      IF (GI.LT.-1.0E-6) GO TO 920
      NAC=NAC+1
      MS1(NAC)=I
920   CONTINUE
      WRITE (IOUT,1090) NAC
      IF (NAC.EQ.0) GO TO 930
      WRITE (IOUT,1100)
      WRITE (IOUT,1480) (MS1(J),J=1,NAC)
930   CONTINUE
      WRITE (IOUT,1150)
      IF (ITER.GE.ITMAX) WRITE (IOUT,1160)
      IF (NFEAS.GE.NFEASCT) WRITE (IOUT,1170)
      IF (IOBJ.GE.ITRM) WRITE (IOUT,1180) ITRM
      IF (KOBJ.GE.ITRM) WRITE (IOUT,1190) ITRM
      WRITE (IOUT,1200) ITER
      WRITE (IOUT,1510) NCAL(1)
      IF (NCON.GT.0) WRITE (IOUT,1520) NCAL(1)
      IF (NFDG.NE.0) WRITE (IOUT,1530) NCAL(2)
      IF (NCON.GT.0.AND.NFDG.EQ.1) WRITE (IOUT,1540) NCAL(2)
C     ------------------------------------------------------------------
C                   RE-SET BASIC PARAMETERS TO INPUT VALUES
C     ------------------------------------------------------------------
940   ITRM=IDM1
      ITMAX=IDM2
      ICNDIR=IDM3
      DELFUN=DM1
      DABFUN=DM2
      CT=DM3
      CTMIN=DM4
      CTL=DM5
      CTLMIN=DM6
      THETA=DM7
      PHI=DM8
      FDCH=DM9
      FDCHM=DM10
      ABOBJ1=DM11
      ALPHAX=DM12
      IGOTO=0
950   CONTINUE
      IF (NSCAL.EQ.0.OR.IGOTO.EQ.0) RETURN
C     UN-SCALE VARIABLES.
      DO 960 I=1,NDV
      C(I)=X(I)
960   X(I)=X(I)*SCAL(I)
      RETURN
C     ------------------------------------------------------------------
C                                FORMATS
C     ------------------------------------------------------------------
C
C
970   FORMAT (///5X,72HA COMPLETELY UNCONSTRAINED FUNCTION WITH A LINEAR
     1 OBJECTIVE IS SPECIFIED//10X,8HLINOBJ =,I5/10X,8HNCON   =,I5/10X,8
     2HNSIDE  =,I5//5X,35HCONTROL RETURNED TO CALLING PROGRAM)
980   FORMAT (///5X,56HCONMIN HAS ACHIEVED A SOLUTION OF OBJ LESS THAN -
     11.0E+40/5X,32HSOLUTION APPEARS TO BE UNBOUNDED/5X,26HOPTIMIZATION
     2IS TERMINATED)
990   FORMAT (5X,17HCONSTRAINT NUMBER,I5)
1000  FORMAT (5X,27HSIDE CONSTRAINT ON VARIABLE,I5)
1010  FORMAT (3X,I5,1H),2X,6E13.5)
1020  FORMAT (/5X,35HLINEAR CONSTRAINT IDENTIFIERS (ISC)/5X,36HNON-ZERO
     1INDICATES LINEAR CONSTRAINT)
1030  FORMAT (3X,I5,1H),2X,15I5)
1040  FORMAT (/5X,26HALL CONSTRAINTS ARE LINEAR)
1050  FORMAT (/5X,30HALL CONSTRAINTS ARE NON-LINEAR)
1060  FORMAT (/5X,9HTHERE ARE,I5,19H ACTIVE CONSTRAINTS)
1070  FORMAT (5X,22HCONSTRAINT NUMBERS ARE)
1080  FORMAT (/5X,9HTHERE ARE,I5,21H VIOLATED CONSTRAINTS)
1090  FORMAT (/5X,9HTHERE ARE,I5,24H ACTIVE SIDE CONSTRAINTS)
1100  FORMAT (5X,43HDECISION VARIABLES AT LOWER OR UPPER BOUNDS,30H (MIN
     1US INDICATES LOWER BOUND))
1110  FORMAT (/5X,22HONE-DIMENSIONAL SEARCH/5X,15HINITIAL SLOPE =,E12.4,
     12X,16HPROPOSED ALPHA =,E12.4)
1120  FORMAT (///5X,35H* * CONMIN DETECTS VLB(I).GT.VUB(I)/5X,57HFIX IS
     1SET X(I)=VLB(I)=VUB(I) = .5*(VLB(I)+VUB(I) FOR I =,I5)
1130  FORMAT (///5X,41H* * CONMIN DETECTS INITIAL X(I).LT.VLB(I)/5X,6HX(
     1I) =,E12.4,2X,8HVLB(I) =,E12.4/5X,35HX(I) IS SET EQUAL TO VLB(I) F
     2OR I =,I5)
1140  FORMAT (///5X,41H* * CONMIN DETECTS INITIAL X(I).GT.VUB(I)/5X,6HX(
     1I) =,E12.4,2X,8HVUB(I) =,E12.4/5X,35HX(I) IS SET EQUAL TO VUB(I) F
     2OR I =,I5)
1150  FORMAT (/5X,21HTERMINATION CRITERION)
1160  FORMAT (10X,17HITER EQUALS ITMAX)
1170  FORMAT (10X,'NFEASCT CONSECUTIVE ITERATIONS FAILED TO PRODUCE A
     1FEASIBLE DESIGN')
1180  FORMAT (10X,43HABS(1-OBJ(I-1)/OBJ(I)) LESS THAN DELFUN FOR,I3,11H
     1ITERATIONS)
1190  FORMAT (10X,43HABS(OBJ(I)-OBJ(I-1))   LESS THAN DABFUN FOR,I3,11H
     1ITERATIONS)
1200  FORMAT (/5X,22HNUMBER OF ITERATIONS =,I5)
1210  FORMAT (/5X,28HCONSTRAINT PARAMETER, BETA =,E14.5)
1220  FORMAT (1H1,////12X,27(2H* )/12X,1H*,51X,1H*/12X,1H*,20X,11HC O N
     1M I N,20X,1H*/12X,1H*,51X,1H*/12X,1H*,15X,21H FORTRAN PROGRAM FOR
     2,15X,1H*/12X,1H*,51X,1H*/12X,1H*,9X,33HCONSTRAINED FUNCTION MINIMI
     3ZATION,9X,1H*/12X,1H*,51X,1H*/12X,27(2H* ))
1230  FORMAT (////5X,33HCONSTRAINED FUNCTION MINIMIZATION//5X,18HCONTROL
     1 PARAMETERS)
1240  FORMAT (/5X,60HIPRINT  NDV    ITMAX    NCON    NSIDE  ICNDIR   NSC
     1AL   NFDG/8I8//5X,12HLINOBJ  ITRM,5X,2HN1,6X,2HN2,6X,2HN3,6X,2HN4,
     26X,2HN5/8I8)
1250  FORMAT (/9X,4HFDCH,12X,5HFDCHM,11X,6HALPHAX,10X,6HABOBJ1/1X,4(2X,E
     114.5))
1260  FORMAT (/9X,2HCT,14X,5HCTMIN,11X,3HCTL,13X,6HCTLMIN/1X,4(2X,E14.5)
     1//9X,5HTHETA,11X,3HPHI,13X,6HDELFUN,10X,6HDABFUN/1X,4(2X,E14.5))
1270  FORMAT (/5X,40HLOWER BOUNDS ON DECISION VARIABLES (VLB))
1280  FORMAT (/5X,40HUPPER BOUNDS ON DECISION VARIABLES (VUB))
1290  FORMAT (////5X,35HUNCONSTRAINED FUNCTION MINIMIZATION//5X,18HCONTR
     1OL PARAMETERS)
1300  FORMAT (/5X,21HSCALING VECTOR (SCAL))
1310  FORMAT (////5X,22HBEGIN ITERATION NUMBER,I5)
1320  FORMAT (/5X,4HCT =,E14.5,5X,5HCTL =,E14.5,5X,5HPHI =,E14.5)
1330  FORMAT (/5X,25HNEW SCALING VECTOR (SCAL))
1340  FORMAT (/5X,15HGRADIENT OF OBJ)
1350  FORMAT (/5X,44HGRADIENTS OF ACTIVE AND VIOLATED CONSTRAINTS)
1360  FORMAT (1H )
1370  FORMAT (/5X,37HPUSH-OFF FACTORS, (THETA(I), I=1,NAC))
1380  FORMAT (/5X,27HSEARCH DIRECTION (S-VECTOR))
1390  FORMAT (/5X,18HCALCULATED ALPHA =,E14.5)
1400  FORMAT (////5X,6HITER =,I5,5X,5HOBJ =,E14.5,5X,16HNO CHANGE IN OBJ
     1)
1410  FORMAT (/5X,5HOBJ =,E15.6,5X,16HNO CHANGE ON OBJ)
1420  FORMAT (/5X,5HOBJ =,E15.6)
1430  FORMAT (////5X,6HITER =,I5,5X,5HOBJ =,E14.5)
1440  FORMAT (//5X,28HINITIAL FUNCTION INFORMATION//5X,5HOBJ =,E15.6)
1450  FORMAT (/5X,29HDECISION VARIABLES (X-VECTOR))
1460  FORMAT (3X,7E13.4)
1470  FORMAT (/5X,28HCONSTRAINT VALUES (G-VECTOR))
1480  FORMAT (5X,15I5)
1490  FORMAT (/5X,59HTHE NUMBER OF ACTIVE AND VIOLATED CONSTRAINTS EXCEE
     1DS N3-1./5X,66HDIMENSIONED SIZE OF MATRICES A AND B AND VECTOR IC
     2IS INSUFFICIENT/5X,61HOPTIMIZATION TERMINATED AND CONTROL RETURNED
     3 TO MAIN PROGRAM.)
1500  FORMAT (1H1,////4X,30HFINAL OPTIMIZATION INFORMATION)
1510  FORMAT (/5X,32HOBJECTIVE FUNCTION WAS EVALUATED,8X,I5,2X,5HTIMES)
1520  FORMAT (/5X,35HCONSTRAINT FUNCTIONS WERE EVALUATED,I10,2X,5HTIMES)
1530  FORMAT (/5X,36HGRADIENT OF OBJECTIVE WAS CALCULATED,I9,2X,5HTIMES)
1540  FORMAT (/5X,40HGRADIENTS OF CONSTRAINTS WERE CALCULATED,I5,2X,5HTI
     1MES)
      END