      SUBROUTINE ML5_0_COEF_CONSTRUCTION_1(P,NHEL,H,IC)
C
C     Modules
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=4)
      INTEGER    NCOMB
      PARAMETER (NCOMB=16)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=3)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=44, NLOOPGROUPS=26, NCTAMPS=85)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=129)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=10,NLOOPWAVEFUNCS=93)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=1, NSQUAREDSO=1, NAMPSO=2)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/ML5_0_I_SO/I_SO
      INTEGER I_LIB
      COMMON/ML5_0_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/ML5_0_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,
     $ -1:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,-1:NLOOPWAVEFUNCS)
      COMMON/ML5_0_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/ML5_0_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.LOOP_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

C     Coefficient construction for loop diagram with ID 4
      CALL FFV1L2_1(PL(0,0),W(1,5),GC_5,ZERO,ZERO,PL(0,1),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,1))
      CALL FFV1L2_1(PL(0,1),W(1,8),GC_5,ZERO,ZERO,PL(0,2),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,1),4,COEFS,4,4,WL(1,0,1,2))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,2),2,4,1,1,4,86,H)
C     Coefficient construction for loop diagram with ID 5
      CALL FFV1L1_2(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,3),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,3))
      CALL FFV1L1_2(PL(0,3),W(1,2),GC_5,ZERO,ZERO,PL(0,4),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,3),4,COEFS,4,4,WL(1,0,1,4))
      CALL FFV1L1_2(PL(0,4),W(1,8),GC_5,ZERO,ZERO,PL(0,5),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,4),4,COEFS,4,4,WL(1,0,1,5))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,5),3,4,2,1,4,87,H)
C     Coefficient construction for loop diagram with ID 6
      CALL FFV1L2_1(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,6),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,6))
      CALL FFV1L2_1(PL(0,6),W(1,2),GC_5,ZERO,ZERO,PL(0,7),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,6),4,COEFS,4,4,WL(1,0,1,7))
      CALL FFV1L2_1(PL(0,7),W(1,8),GC_5,ZERO,ZERO,PL(0,8),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,7),4,COEFS,4,4,WL(1,0,1,8))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,8),3,4,2,1,4,88,H)
C     Coefficient construction for loop diagram with ID 7
      CALL FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MB,ZERO,PL(0,9),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,9))
      CALL FFV1L2_1(PL(0,9),W(1,8),GC_5,MDL_MB,ZERO,PL(0,10),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,9),4,COEFS,4,4,WL(1,0,1,10))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,10),2,4,3,1,1,89,H)
C     Coefficient construction for loop diagram with ID 8
      CALL FFV1L1_2(PL(0,0),W(1,1),GC_5,MDL_MB,ZERO,PL(0,11),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,11))
      CALL FFV1L1_2(PL(0,11),W(1,2),GC_5,MDL_MB,ZERO,PL(0,12),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,11),4,COEFS,4,4,WL(1,0,1,12))
      CALL FFV1L1_2(PL(0,12),W(1,8),GC_5,MDL_MB,ZERO,PL(0,13),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,12),4,COEFS,4,4,WL(1,0,1,13))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,13),3,4,4,1,1,90,H)
C     Coefficient construction for loop diagram with ID 9
      CALL FFV1L2_1(PL(0,0),W(1,1),GC_5,MDL_MB,ZERO,PL(0,14),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,14))
      CALL FFV1L2_1(PL(0,14),W(1,2),GC_5,MDL_MB,ZERO,PL(0,15),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,14),4,COEFS,4,4,WL(1,0,1,15))
      CALL FFV1L2_1(PL(0,15),W(1,8),GC_5,MDL_MB,ZERO,PL(0,16),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,15),4,COEFS,4,4,WL(1,0,1,16))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,16),3,4,4,1,1,91,H)
C     Coefficient construction for loop diagram with ID 10
      CALL FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MT,MDL_WT,PL(0,17),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,17))
      CALL FFV1L2_1(PL(0,17),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,18),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,17),4,COEFS,4,4,WL(1,0,1,18))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,18),2,4,5,1,1,92,H)
C     Coefficient construction for loop diagram with ID 11
      CALL FFV1L1P0_3(PL(0,0),W(1,3),GC_5,ZERO,ZERO,PL(0,19),COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,19))
      CALL FFV1L3_2(PL(0,19),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,20),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,19),4,COEFS,4,4,WL(1,0,1,20))
      CALL FFV1L1_2(PL(0,20),W(1,5),GC_5,MDL_MT,MDL_WT,PL(0,21),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,20),4,COEFS,4,4,WL(1,0,1,21))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,21),2,4,6,1,1,93,H)
C     Coefficient construction for loop diagram with ID 12
      CALL FFV1L3_1(PL(0,0),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,22),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,22))
      CALL FFV1L2P0_3(PL(0,22),W(1,4),GC_5,ZERO,ZERO,PL(0,23),COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,22),4,COEFS,4,4,WL(1,0,1,23))
      CALL VVV1L2P0_1(PL(0,23),W(1,5),GC_4,ZERO,ZERO,PL(0,24),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,23),4,COEFS,4,4,WL(1,0,1,24))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,24),2,4,7,1,1,94,H)
C     Coefficient construction for loop diagram with ID 13
      CALL FFV1L1P0_3(PL(0,0),W(1,6),GC_5,ZERO,ZERO,PL(0,25),COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,25))
      CALL FFV1L3_2(PL(0,25),W(1,9),GC_5,MDL_MT,MDL_WT,PL(0,26),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,25),4,COEFS,4,4,WL(1,0,1,26))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,26),1,4,8,1,1,95,H)
C     Coefficient construction for loop diagram with ID 14
      CALL FFV1L2_1(PL(0,0),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,27),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,27))
      CALL FFV1L2P0_3(PL(0,27),W(1,4),GC_5,ZERO,ZERO,PL(0,28),COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,27),4,COEFS,4,4,WL(1,0,1,28))
      CALL FFV1L3_1(PL(0,28),W(1,6),GC_5,MDL_MT,MDL_WT,PL(0,29),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,28),4,COEFS,4,4,WL(1,0,1,29))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,29),2,4,9,1,1,96,H)
C     Coefficient construction for loop diagram with ID 15
      CALL VVV1L2P0_1(PL(0,0),W(1,2),GC_4,ZERO,ZERO,PL(0,30),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,30))
      CALL FFV1L3_2(PL(0,30),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,31),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,30),4,COEFS,4,4,WL(1,0,1,31))
      CALL FFV1L1P0_3(PL(0,31),W(1,6),GC_5,ZERO,ZERO,PL(0,32),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,31),4,COEFS,4,4,WL(1,0,1,32))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,32),2,4,10,1,1,97,H)
C     Coefficient construction for loop diagram with ID 16
      CALL FFV1L1P0_3(PL(0,0),W(1,10),GC_5,ZERO,ZERO,PL(0,33),COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,33))
      CALL FFV1L3_2(PL(0,33),W(1,7),GC_5,MDL_MT,MDL_WT,PL(0,34),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,33),4,COEFS,4,4,WL(1,0,1,34))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,34),1,4,11,1,1,98,H)
C     Coefficient construction for loop diagram with ID 17
      CALL FFV1L1_2(PL(0,0),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,35),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,35))
      CALL FFV1L1P0_3(PL(0,35),W(1,3),GC_5,ZERO,ZERO,PL(0,36),COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,35),4,COEFS,4,4,WL(1,0,1,36))
      CALL FFV1L3_2(PL(0,36),W(1,7),GC_5,MDL_MT,MDL_WT,PL(0,37),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,36),4,COEFS,4,4,WL(1,0,1,37))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,37),2,4,12,1,1,99,H)
C     Coefficient construction for loop diagram with ID 18
      CALL FFV1L3_1(PL(0,30),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,38),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,30),4,COEFS,4,4,WL(1,0,1,38))
      CALL FFV1L2P0_3(PL(0,38),W(1,7),GC_5,ZERO,ZERO,PL(0,39),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,38),4,COEFS,4,4,WL(1,0,1,39))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,39),2,4,13,1,1,100,H)
C     Coefficient construction for loop diagram with ID 19
      CALL FFV1L2_1(PL(0,0),W(1,1),GC_5,MDL_MT,MDL_WT,PL(0,40),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,40))
      CALL FFV1L2P0_3(PL(0,40),W(1,4),GC_5,ZERO,ZERO,PL(0,41),COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,40),4,COEFS,4,4,WL(1,0,1,41))
      CALL FFV1L3_1(PL(0,41),W(1,10),GC_5,MDL_MT,MDL_WT,PL(0,42),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,41),4,COEFS,4,4,WL(1,0,1,42))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,42),2,4,14,1,1,101,H)
C     Coefficient construction for loop diagram with ID 20
      CALL FFV1L1_2(PL(0,0),W(1,1),GC_5,MDL_MT,MDL_WT,PL(0,43),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,43))
      CALL FFV1L1P0_3(PL(0,43),W(1,3),GC_5,ZERO,ZERO,PL(0,44),COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,43),4,COEFS,4,4,WL(1,0,1,44))
      CALL FFV1L3_2(PL(0,44),W(1,9),GC_5,MDL_MT,MDL_WT,PL(0,45),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,44),4,COEFS,4,4,WL(1,0,1,45))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,45),2,4,15,1,1,102,H)
C     Coefficient construction for loop diagram with ID 21
      CALL FFV1L1_2(PL(0,43),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,46),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,43),4,COEFS,4,4,WL(1,0,1,46))
      CALL FFV1L1P0_3(PL(0,46),W(1,3),GC_5,ZERO,ZERO,PL(0,47),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,46),4,COEFS,4,4,WL(1,0,1,47))
      CALL FFV1L3_2(PL(0,47),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,48),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,47),4,COEFS,4,4,WL(1,0,1,48))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,48),3,4,16,1,1,103,H)
C     Coefficient construction for loop diagram with ID 22
      CALL FFV1L1_2(PL(0,46),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,49),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,46),4,COEFS,4,4,WL(1,0,1,49))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,49),3,4,17,1,1,104,H)
C     Coefficient construction for loop diagram with ID 23
      CALL FFV1L2_1(PL(0,40),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,50),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,40),4,COEFS,4,4,WL(1,0,1,50))
      CALL FFV1L2_1(PL(0,50),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,51),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,50),4,COEFS,4,4,WL(1,0,1,51))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,51),3,4,17,1,1,105,H)
C     Coefficient construction for loop diagram with ID 24
      CALL FFV1L2P0_3(PL(0,50),W(1,4),GC_5,ZERO,ZERO,PL(0,52),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,50),4,COEFS,4,4,WL(1,0,1,52))
      CALL FFV1L3_1(PL(0,52),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,53),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,52),4,COEFS,4,4,WL(1,0,1,53))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,53),3,4,18,1,1,106,H)
C     Coefficient construction for loop diagram with ID 25
      CALL VVV1L2P0_1(PL(0,44),W(1,2),GC_4,ZERO,ZERO,PL(0,54),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,44),4,COEFS,4,4,WL(1,0,1,54))
      CALL FFV1L3_2(PL(0,54),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,55),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,54),4,COEFS,4,4,WL(1,0,1,55))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,55),3,4,19,1,1,107,H)
C     Coefficient construction for loop diagram with ID 26
      CALL VVV1L2P0_1(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,56),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,56))
      CALL FFV1L3_2(PL(0,56),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,57),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,57))
      CALL FFV1L1P0_3(PL(0,57),W(1,10),GC_5,ZERO,ZERO,PL(0,58),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,57),4,COEFS,4,4,WL(1,0,1,58))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,58),2,4,20,1,1,108,H)
C     Coefficient construction for loop diagram with ID 27
      CALL FFV1L3_1(PL(0,56),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,59),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,59))
      CALL FFV1L2P0_3(PL(0,59),W(1,9),GC_5,ZERO,ZERO,PL(0,60),COEFS)
      CALL ML5_0_UPDATE_WL_2_0(WL(1,0,1,59),4,COEFS,4,4,WL(1,0,1,60))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,60),2,4,21,1,1,109,H)
C     Coefficient construction for loop diagram with ID 28
      CALL FFV1L2_1(PL(0,59),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,61),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,59),4,COEFS,4,4,WL(1,0,1,61))
      CALL FFV1L2P0_3(PL(0,61),W(1,4),GC_5,ZERO,ZERO,PL(0,62),COEFS)
      CALL ML5_0_UPDATE_WL_3_0(WL(1,0,1,61),4,COEFS,4,4,WL(1,0,1,62))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,62),3,4,22,1,1,110,H)
C     Coefficient construction for loop diagram with ID 29
      CALL VVVV1L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,63)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0,1,63))
      CALL VVVV3L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,64)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0,1,64))
      CALL VVVV4L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,65)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0,1,65))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,63),1,4,7,1,1,111,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,64),1,4,7,1,1,112,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,65),1,4,7,1,1,113,H)
C     Coefficient construction for loop diagram with ID 30
      CALL VVV1L2P0_1(PL(0,56),W(1,2),GC_4,ZERO,ZERO,PL(0,66),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,66))
      CALL FFV1L3_2(PL(0,66),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,67),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0,1,67))
      CALL FFV1L1P0_3(PL(0,67),W(1,3),GC_5,ZERO,ZERO,PL(0,68),COEFS)
      CALL ML5_0_UPDATE_WL_3_0(WL(1,0,1,67),4,COEFS,4,4,WL(1,0,1,68))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,68),3,4,23,1,1,114,H)
C     Coefficient construction for loop diagram with ID 31
      CALL FFV1L3_1(PL(0,66),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,69),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0,1,69))
      CALL FFV1L2P0_3(PL(0,69),W(1,4),GC_5,ZERO,ZERO,PL(0,70),COEFS)
      CALL ML5_0_UPDATE_WL_3_0(WL(1,0,1,69),4,COEFS,4,4,WL(1,0,1,70))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,70),3,4,24,1,1,115,H)
C     Coefficient construction for loop diagram with ID 32
      CALL VVV1L2P0_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,71),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,71))
      CALL VVV1L2P0_1(PL(0,71),W(1,8),GC_4,ZERO,ZERO,PL(0,72),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,71),4,COEFS,4,4,WL(1,0,1,72))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,72),2,4,1,2,1,116,H)
C     Coefficient construction for loop diagram with ID 33
      CALL VVV1L2P0_1(PL(0,66),W(1,8),GC_4,ZERO,ZERO,PL(0,73),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0,1,73))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,73),3,4,2,1,1,117,H)
C     Coefficient construction for loop diagram with ID 34
      CALL VVVV1L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO,PL(0,74)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,74))
      CALL VVVV3L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO,PL(0,75)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,75))
      CALL VVVV4L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO,PL(0,76)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0,1,76))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,74),1,4,25,2,1,118,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,75),1,4,25,2,1,119,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,76),1,4,25,2,1,120,H)
C     Coefficient construction for loop diagram with ID 35
      CALL VVVV1L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO,PL(0,77)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0,1,77))
      CALL VVVV3L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO,PL(0,78)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0,1,78))
      CALL VVVV4L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO,PL(0,79)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0,1,79))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,77),1,4,26,2,1,121,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,78),1,4,26,2,1,122,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,79),1,4,26,2,1,123,H)
C     Coefficient construction for loop diagram with ID 36
      CALL VVVV1L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,80)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,80))
      CALL VVVV3L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,81)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,81))
      CALL VVVV4L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO,PL(0,82)
     $ ,COEFS)
      CALL ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1,82))
      CALL VVV1L2P0_1(PL(0,80),W(1,8),GC_4,ZERO,ZERO,PL(0,83),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,80),4,COEFS,4,4,WL(1,0,1,83))
      CALL VVV1L2P0_1(PL(0,81),W(1,8),GC_4,ZERO,ZERO,PL(0,84),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,81),4,COEFS,4,4,WL(1,0,1,84))
      CALL VVV1L2P0_1(PL(0,82),W(1,8),GC_4,ZERO,ZERO,PL(0,85),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,82),4,COEFS,4,4,WL(1,0,1,85))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,83),1,4,1,2,1,124,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,84),1,4,1,2,1,125,H)
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,85),1,4,1,2,1,126,H)
C     Coefficient construction for loop diagram with ID 37
      CALL GHGHGL2_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,86),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1,86))
      CALL GHGHGL2_1(PL(0,86),W(1,8),GC_4,ZERO,ZERO,PL(0,87),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,86),1,COEFS,1,1,WL(1,0,1,87))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,87),2,1,1,1,1,127,H)
C     Coefficient construction for loop diagram with ID 38
      CALL GHGHGL1_2(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,88),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1,88))
      CALL GHGHGL1_2(PL(0,88),W(1,2),GC_4,ZERO,ZERO,PL(0,89),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,88),1,COEFS,1,1,WL(1,0,1,89))
      CALL GHGHGL1_2(PL(0,89),W(1,8),GC_4,ZERO,ZERO,PL(0,90),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,89),1,COEFS,1,1,WL(1,0,1,90))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,90),3,1,2,1,1,128,H)
C     Coefficient construction for loop diagram with ID 39
      CALL GHGHGL2_1(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,91),COEFS)
      CALL ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1,91))
      CALL GHGHGL2_1(PL(0,91),W(1,2),GC_4,ZERO,ZERO,PL(0,92),COEFS)
      CALL ML5_0_UPDATE_WL_1_1(WL(1,0,1,91),1,COEFS,1,1,WL(1,0,1,92))
      CALL GHGHGL2_1(PL(0,92),W(1,8),GC_4,ZERO,ZERO,PL(0,93),COEFS)
      CALL ML5_0_UPDATE_WL_2_1(WL(1,0,1,92),1,COEFS,1,1,WL(1,0,1,93))
      CALL ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,93),3,1,2,1,1,129,H)
C     At this point, all loop coefficients needed for (QCD=6), i.e. of
C      split order ID=1, are computed.
      IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 4000

      GOTO 1001
 4000 CONTINUE
      LOOP_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


MODULE domwri
   !!======================================================================
   !!                       ***  MODULE domwri  ***
   !! Ocean initialization : write the ocean domain mesh file(s)
   !!======================================================================
   !! History :  OPA  ! 1997-02  (G. Madec)  Original code
   !!            8.1  ! 1999-11  (M. Imbard)  NetCDF FORMAT with IOIPSL
   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90 and several file
   !!            3.0  ! 2008-01  (S. Masson)  add dom_uniq
   !!            4.0  ! 2016-01  (G. Madec)  simplified mesh_mask.nc file
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   dom_wri        : create and write mesh and mask file(s)
   !!   dom_uniq       : identify unique point of a grid (TUVF)
   !!   dom_stiff      : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate)
   !!----------------------------------------------------------------------
   USE dom_oce         ! ocean space and time domain
   USE phycst ,   ONLY :   rsmall
   USE wet_dry,   ONLY :   ll_wd  ! Wetting and drying
   !
   USE in_out_manager  ! I/O manager
   USE iom             ! I/O library
   USE lbclnk          ! lateral boundary conditions - mpp exchanges
   USE lib_mpp         ! MPP library

   IMPLICIT NONE
   PRIVATE

   PUBLIC   dom_wri              ! routine called by inidom.F90
   PUBLIC   dom_stiff            ! routine called by inidom.F90

   !! * Substitutions
   !!----------------------------------------------------------------------
   !!                   ***  vectopt_loop_substitute  ***
   !!----------------------------------------------------------------------
   !! ** purpose :   substitute the inner loop start/end indices with CPP macro
   !!                allow unrolling of do-loop (useful with vector processors)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: vectopt_loop_substitute.h90 10068 2018-08-28 14:09:04Z nicolasmartin $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: domwri.F90 10068 2018-08-28 14:09:04Z nicolasmartin $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE dom_wri
      !!----------------------------------------------------------------------
      !!                  ***  ROUTINE dom_wri  ***
      !!
      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
      !!      ocean domain informations (mesh and mask arrays). This (these)
      !!      file(s) is (are) used for visualisation (SAXO software) and
      !!      diagnostic computation.
      !!
      !! ** Method  :   create a file with all domain related arrays
      !!
      !! ** output file :   meshmask.nc  : domain size, horizontal grid-point position,
      !!                                   masks, depth and vertical scale factors
      !!----------------------------------------------------------------------
      INTEGER           ::   inum    ! temprary units for 'mesh_mask.nc' file
      CHARACTER(len=21) ::   clnam   ! filename (mesh and mask informations)
      INTEGER           ::   ji, jj, jk   ! dummy loop indices
      INTEGER           ::   izco, izps, isco, icav
      !
      REAL(wp), DIMENSION(jpi,jpj)     ::   zprt, zprw     ! 2D workspace
      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdepu, zdepv   ! 3D workspace
      !!----------------------------------------------------------------------
      !
      IF(lwp) WRITE(numout,*)
      IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)'
      IF(lwp) WRITE(numout,*) '~~~~~~~'

      clnam = 'mesh_mask'  ! filename (mesh and mask informations)

      !                                  ! ============================
      !                                  !  create 'mesh_mask.nc' file
      !                                  ! ============================
      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib )
      !
      !                                                         ! global domain size
      CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
      CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
      CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 )

      !                                                         ! domain characteristics
      CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
      !                                                         ! type of vertical coordinate
      IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF
      IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF
      IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF
      CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 )
      CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 )
      CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 )
      !                                                         ! ocean cavities under iceshelves
      IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF
      CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 )

      !                                                         ! masks
      CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask
      CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 )
      CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 )
      CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 )

      CALL dom_uniq( zprw, 'T' )
      DO jj = 1, jpj
         DO ji = 1, jpi
            zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
         END DO
      END DO                             !    ! unique point mask
      CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 )
      CALL dom_uniq( zprw, 'U' )
      DO jj = 1, jpj
         DO ji = 1, jpi
            zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
         END DO
      END DO
      CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 )
      CALL dom_uniq( zprw, 'V' )
      DO jj = 1, jpj
         DO ji = 1, jpi
            zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
         END DO
      END DO
      CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 )
!!gm  ssfmask has been removed  ==>> find another solution to defined fmaskutil
!!    Here we just remove the output of fmaskutil.
!      CALL dom_uniq( zprw, 'F' )
!      DO jj = 1, jpj
!         DO ji = 1, jpi
!            zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
!         END DO
!      END DO
!      CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 )
!!gm

      !                                                         ! horizontal mesh (inum3)
      CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 )     !    ! latitude
      CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 )

      CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude
      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 )

      CALL iom_rstput( 0, 0, inum, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
      CALL iom_rstput( 0, 0, inum, 'e1u', e1u, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'e1v', e1v, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'e1f', e1f, ktype = jp_r8 )

      CALL iom_rstput( 0, 0, inum, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
      CALL iom_rstput( 0, 0, inum, 'e2u', e2u, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'e2v', e2v, ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'e2f', e2f, ktype = jp_r8 )

      CALL iom_rstput( 0, 0, inum, 'ff_f', ff_f, ktype = jp_r8 )       !    ! coriolis factor
      CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 )

      ! note that mbkt is set to 1 over land ==> use surface tmask
      zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp )
      CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 )     !    ! nb of ocean T-points
      zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp )
      CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 )       !    ! nb of ocean T-points
      zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp )
      CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 )   !    ! nb of ocean T-points
      !															             ! vertical mesh
      CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8  )    !    ! scale factors
      CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8  )
      CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8  )
      CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8  )
      !
      CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 )  ! stretched system
      CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'gdept_0'  , gdept_0  , ktype = jp_r8 )
      CALL iom_rstput( 0, 0, inum, 'gdepw_0'  , gdepw_0  , ktype = jp_r8 )
      !
      IF( ln_sco ) THEN                                         ! s-coordinate stiffness
         CALL dom_stiff( zprt )
         CALL iom_rstput( 0, 0, inum, 'stiffness', zprt )       ! Max. grid stiffness ratio
      ENDIF
      !
      IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0'   , ht_0   , ktype = jp_r8 )

      !                                     ! ============================
      CALL iom_close( inum )                !        close the files
      !                                     ! ============================
   END SUBROUTINE dom_wri

   SUBROUTINE dom_uniq( puniq, cdgrd )
      !!----------------------------------------------------------------------
      !!                  ***  ROUTINE dom_uniq  ***
      !!
      !! ** Purpose :   identify unique point of a grid (TUVF)
      !!
      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
      !!                2) check which elements have been changed
      !!----------------------------------------------------------------------
      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !
      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !
      !
      REAL(wp) ::  zshift   ! shift value link to the process number
      INTEGER  ::  ji       ! dummy loop indices
      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
      REAL(wp), DIMENSION(jpi,jpj) ::   ztstref
      !!----------------------------------------------------------------------
      !
      ! build an array with different values for each element
      ! in mpp: make sure that these values are different even between process
      ! -> apply a shift value according to the process number
      zshift = jpi * jpj * ( narea - 1 )
      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
      !
      puniq(:,:) = ztstref(:,:)                   ! default definition
      CALL lbc_lnk( puniq, cdgrd, 1. )            ! apply boundary conditions
      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed
      !
      puniq(:,:) = 1.                             ! default definition
      ! fill only the inner part of the cpu with llbl converted into real
      puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )
      !
   END SUBROUTINE dom_uniq

   SUBROUTINE dom_stiff( px1 )
      !!----------------------------------------------------------------------
      !!                  ***  ROUTINE dom_stiff  ***
      !!
      !! ** Purpose :   Diagnose maximum grid stiffness/hydrostatic consistency
      !!
      !! ** Method  :   Compute Haney (1991) hydrostatic condition ratio
      !!                Save the maximum in the vertical direction
      !!                (this number is only relevant in s-coordinates)
      !!
      !!                Haney, 1991, J. Phys. Oceanogr., 21, 610-619.
      !!----------------------------------------------------------------------
      REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL ::   px1   ! stiffness
      !
      INTEGER  ::   ji, jj, jk
      REAL(wp) ::   zrxmax
      REAL(wp), DIMENSION(4) ::   zr1
      REAL(wp), DIMENSION(jpi,jpj) ::   zx1
      !!----------------------------------------------------------------------
      zx1(:,:) = 0._wp
      zrxmax   = 0._wp
      zr1(:)   = 0._wp
      !
      DO ji = 2, jpim1
         DO jj = 2, jpjm1
            DO jk = 1, jpkm1
!!gm   remark: dk(gdepw) = e3t   ===>>>  possible simplification of the following calculation....
!!             especially since it is gde3w which is used to compute the pressure gradient
!!             furthermore, I think gdept_0 should be used below instead of w point in the numerator
!!             so that the ratio is computed at the same point (i.e. uw and vw) ....
               zr1(1) = ABS(  ( gdepw_0(ji  ,jj,jk  )-gdepw_0(ji-1,jj,jk  )               &
                    &          +gdepw_0(ji  ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) )             &
                    &       / ( gdepw_0(ji  ,jj,jk  )+gdepw_0(ji-1,jj,jk  )               &
                    &          -gdepw_0(ji  ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall )  ) * umask(ji-1,jj,jk)
               zr1(2) = ABS(  ( gdepw_0(ji+1,jj,jk  )-gdepw_0(ji  ,jj,jk  )               &
                    &          +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji  ,jj,jk+1) )             &
                    &       / ( gdepw_0(ji+1,jj,jk  )+gdepw_0(ji  ,jj,jk  )               &
                    &          -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji  ,jj,jk+1) + rsmall )  ) * umask(ji  ,jj,jk)
               zr1(3) = ABS(  ( gdepw_0(ji,jj+1,jk  )-gdepw_0(ji,jj  ,jk  )               &
                    &          +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj  ,jk+1) )             &
                    &       / ( gdepw_0(ji,jj+1,jk  )+gdepw_0(ji,jj  ,jk  )               &
                    &          -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj  ,jk+1) + rsmall )  ) * vmask(ji,jj  ,jk)
               zr1(4) = ABS(  ( gdepw_0(ji,jj  ,jk  )-gdepw_0(ji,jj-1,jk  )               &
                    &          +gdepw_0(ji,jj  ,jk+1)-gdepw_0(ji,jj-1,jk+1) )             &
                    &       / ( gdepw_0(ji,jj  ,jk  )+gdepw_0(ji,jj-1,jk  )               &
                    &          -gdepw_0(ji,jj  ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall )  ) * vmask(ji,jj-1,jk)
               zrxmax = MAXVAL( zr1(1:4) )
               zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax )
            END DO
         END DO
      END DO
      CALL lbc_lnk( zx1, 'T', 1. )
      !
      IF( PRESENT( px1 ) )    px1 = zx1
      !
      zrxmax = MAXVAL( zx1 )
      !
      IF( lk_mpp )   CALL mpp_max( zrxmax ) ! max over the global domain
      !
      IF(lwp) THEN
         WRITE(numout,*)
         WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax
         WRITE(numout,*) '~~~~~~~~~'
      ENDIF
      !
   END SUBROUTINE dom_stiff

   !!======================================================================
END MODULE domwri


!
! ODZeeman_Predictor
!
! Module containing routines to compute the predictors for calculations
! gaseous absorption affected by Zeeman spilitting in
! the Optical Depth Pressure Space (ODPS).
!
!
! CREATION HISTORY:
!       Written by:     Yong Han, JCSDA, NOAA/NESDIS 20-Sep-2008
!

MODULE ODZeeman_Predictor

  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,            ONLY: fp
  USE Message_Handler,       ONLY: SUCCESS, FAILURE, Display_Message
  USE ODPS_Predictor_Define, ONLY: ODPS_Predictor_type
  USE ODPS_Define,           ONLY: ODPS_type

  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Public routines
  PUBLIC :: Compute_Predictors_zssmis
  PUBLIC :: Compute_Predictors_zssmis_TL
  PUBLIC :: Compute_Predictors_zssmis_AD
  PUBLIC :: Compute_Predictors_zamsua
  PUBLIC :: Compute_Predictors_zamsua_TL
  PUBLIC :: Compute_Predictors_zamsua_AD

  ! Public parameters
  PUBLIC :: N_ZCOMPONENTS
  PUBLIC :: N_ZABSORBERS
  PUBLIC :: MAX_N_PREDICTORS_ZSSMIS
  PUBLIC :: MAX_N_PREDICTORS_ZAMSUA
  PUBLIC :: ZSSMIS_ChannelMap
  PUBLIC :: ZAMSUA_ChannelMap
  PUBLIC :: ODPS_gINDEX_ZSSMIS
  PUBLIC :: ODPS_gINDEX_ZAMSUA

  ! ----------
  ! Parameters
  ! ----------
  REAL(fp), PARAMETER :: ZERO = 0.0_fp, ONE = 1.0_fp, TWO = 2.0_fp

  INTEGER, PARAMETER :: N_ZCOMPONENTS = 1
  ! set this variable to 1 although it should be 1 to consistant with the ODPS structure (for
  ! Zeeman applications only O2 need to be considered, which will be include as a fixed gas, decribed
  ! by pressure and temperature.
  INTEGER, PARAMETER :: N_ZABSORBERS  = 1

  !----------------------------------------------------------------
  !  ZSSMIS parameters (SSMIS channels 19 - 22)
  !----------------------------------------------------------------
  INTEGER, PARAMETER :: ODPS_gINDEX_ZSSMIS = 4  ! ODPS group index
  INTEGER, PARAMETER :: MAX_N_PREDICTORS_ZSSMIS = 18
  ! Global to ZSSMIS channel index mapping
  INTEGER, PARAMETER :: N_CHANNELS_SSMIS = 24
  INTEGER, PARAMETER :: ZSSMIS_ChannelMap(N_CHANNELS_SSMIS) = (/&
                                      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
                                      0, 0, 0, 0, 0, 0, 0, 0, 1, 2, &
                                      3, 4, 0, 0 /)

  !----------------------------------------------------------------
  !  ZAMSUA parameters (AMSUA channel 14)
  !----------------------------------------------------------------
  INTEGER, PARAMETER :: MAX_N_PREDICTORS_ZAMSUA = 7
  INTEGER, PARAMETER :: ODPS_gINDEX_ZAMSUA = 5  ! ODPS group index
  ! Global to ZAMSUA channel index mapping
  INTEGER, PARAMETER :: N_CHANNELS_AMSUA = 15
  INTEGER, PARAMETER :: ZAMSUA_ChannelMap(N_CHANNELS_AMSUA) = (/&
                                      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
                                      0, 0, 0, 1, 0/)

CONTAINS

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zssmis
!
! PURPOSE:
!       Subroutine to compute predictors for the ZSSMIS sensor (a virtual sensor
!       created for SSMIS Zeeman channels 19, 20, 21 and 22
!
! CALLING SEQUENCE:
!       CALL  Compute_Predictors_zssmis(Temperature,   &
!                                       Be,            &
!                                       CosBK,         &
!                                       Doppler_Shift, &
!                                       Secang,        &
!                                       Predictor )
!
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!         Be    :        Earth magnetic filed strength
!                        UNITS:      Guass (range 0.2 - 0.7)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  scalar
!                        ATTRIBUTES: INTENT(IN)
!
!         CosBK :        Cosine of the angle between the Earth magnetic
!                        field and the electromagnetic wave propagation
!                        direction
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Doppler_Shift :  Doppler shift due Earth ratation, positive when
!                        the emitter moves towards the sensor
!                        UNITS:      KHz
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!             Secang  :  Secant of the zenith angle profile
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Predictor:      Predictor structure
!                       UNITS:      N/A
!                       TYPE:       TYPE(ODPS_Predictor_type)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!------------------------------------------------------------------------------

  SUBROUTINE Compute_Predictors_zssmis(Temperature,   &
                                       Be,            &
                                       CosBK,         &
                                       Doppler_Shift, &
                                       Secang,        &
                                       Predictor )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Be
    REAL(fp), INTENT( IN ) :: CosBK
    REAL(fp), INTENT( IN ) :: Doppler_Shift
    REAL(fp), INTENT( IN ) :: Secang(:)
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor

    ! LOCAL
    REAL(fp) :: Be2, Be3, OneOverBe, OneOverBe2, CosBK2, OneOverT
    INTEGER  :: k

    Be2         = Be  * Be
    Be3         = Be2 * Be
    OneOverBe   = ONE / Be
    OneOverBe2  = OneOverBe * OneOverBe
    CosBK2     = CosBK * CosBK

    DO k = 1, Predictor%n_Layers
      ! Predictors associated Temperature
      OneOverT = 300.0_fp / Temperature(k)
      Predictor%X(k, 1,  1)  = OneOverT                ! 1/T
      Predictor%X(k, 2,  1)  = OneOverT * CosBK2       ! COS(BK_ang)**2 / T
      Predictor%X(k, 3,  1)  = OneOverT / Be           ! 1 / (T*Be)
      Predictor%X(k, 4,  1)  = OneOverT * CosBK / Be   ! COS(BK_ang) / (T*Be)
      Predictor%X(k, 5,  1)  = OneOverT * CosBK / Be2  ! COS(BK_ang) / (T*Be**2)
    END DO

    ! Constant predictor
    Predictor%X(:, 6,  1)  = ONE                       ! 1  - constant term
    Predictor%X(:, 7,  1)  = CosBK                     ! COS(BK_ang)
    Predictor%X(:, 8,  1)  = CosBK2                    ! COS(BK_ang)**2
    Predictor%X(:, 9,  1)  = OneOverBe                 ! 1 / Be
    Predictor%X(:, 10, 1)  = OneOverBe2                ! 1 / Be**2
    Predictor%X(:, 11, 1)  = OneOverBe2 * OneOverBe    ! 1 / Be^3
    Predictor%X(:, 12, 1)  = CosBK * Be2               ! COS(BK_ang) * Be**2
    Predictor%X(:, 13, 1)  = CosBK2 * Be2              ! (COS(BK_ang) * Be)**2
    Predictor%X(:, 14, 1)  = CosBK * Be3               ! COS(BK_ang) * Be**3
    Predictor%X(:, 15, 1)  = Be                        ! Be
    Predictor%X(:, 16, 1)  = Be3                       ! Be**3
    Predictor%X(:, 17, 1)  = CosBK  * Be               ! COS(BK_ang)*Be
    Predictor%X(:, 18, 1)  = CosBK2 * Be               ! COS(BK_ang)**2*Be

    Predictor%n_CP(1) = MAX_N_PREDICTORS_ZSSMIS

    ! pass Doppler shift and Secant angle to Predicotr structre
    Predictor%u = Doppler_Shift
    Predictor%Secant_Zenith = Secang

  END SUBROUTINE Compute_Predictors_zssmis

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zssmis_TL
!
! PURPOSE:
!       Subroutine to compute TL predictors for the ZSSMIS sensor (a virtual sensor
!       created for SSMIS Zeeman channels 19, 20, 21 and 22)
!
! CALLING SEQUENCE:
!
!       CALL Compute_Predictors_zssmis_TL(Temperature,   &
!                                         Be,            &
!                                         CosBK,         &
!                                         Temperature_TL,&
!                                         Predictor_TL )
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!         Be    :        Earth magnetic filed strength
!                        UNITS:      Guass (range 0.2 - 0.7)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  scalar
!                        ATTRIBUTES: INTENT(IN)
!
!         CosBK :        Cosine of the angle between the Earth magnetic
!                        field and the electromagnetic wave propagation
!                        direction
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:  TL Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Predictor_TL:   TL Predictor structure
!                       UNITS:      N/A
!                       TYPE:       TYPE(ODPS_Predictor_type)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!------------------------------------------------------------------------------

  SUBROUTINE Compute_Predictors_zssmis_TL(Temperature,   &
                                          Be,            &
                                          CosBK,         &
                                          Temperature_TL,&
                                          Predictor_TL )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Be
    REAL(fp), INTENT( IN ) :: CosBK
    REAL(fp), INTENT( IN ) :: Temperature_TL(:)
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor_TL

    ! LOCAL
    REAL(fp) :: Be2, CosBK2, OneOverT, OneOverT_TL
    INTEGER  :: k

    Be2         = Be  * Be
    CosBK2     = CosBK * CosBK

    DO k = 1, Predictor_TL%n_Layers
      ! Predictors associated Temperature
      OneOverT = 300.0_fp / Temperature(k)
      OneOverT_TL = -(OneOverT / Temperature(k))*Temperature_TL(k)
      Predictor_TL%X(k, 1,  1)  = OneOverT_TL
      Predictor_TL%X(k, 2,  1)  = OneOverT_TL * CosBK2
      Predictor_TL%X(k, 3,  1)  = OneOverT_TL / Be
      Predictor_TL%X(k, 4,  1)  = OneOverT_TL * CosBK / Be
      Predictor_TL%X(k, 5,  1)  = OneOverT_TL * CosBK / Be2
    END DO

    ! Constant predictor
    Predictor_TL%X(:, 6:18,  1)  = ZERO

    Predictor_TL%n_CP(1) = MAX_N_PREDICTORS_ZSSMIS

  END SUBROUTINE Compute_Predictors_zssmis_TL

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zssmis_AD
!
! PURPOSE:
!       Subroutine to compute AD predictors for the ZSSMIS sensor (a virtual sensor
!       created for SSMIS Zeeman channels 19, 20, 21 and 22)
!
! CALLING SEQUENCE:
!
!        CALL Compute_Predictors_zssmis_AD(Temperature,   &
!                                          Be,            &
!                                          CosBK,         &
!                                          Predictor_AD,  &
!                                          Temperature_AD )
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!         Be    :        Earth magnetic filed strength
!                        UNITS:      Guass (range 0.2 - 0.7)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  scalar
!                        ATTRIBUTES: INTENT(IN)
!
!         CosBK :        Cosine of the angle between the Earth magnetic
!                        field and the electromagnetic wave propagation
!                        direction
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Predictor_AD:    AD Predictor structure
!                        UNITS:      N/A
!                        TYPE:       TYPE(ODPS_Predictor_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(INOUT)
!
! OUTPUT ARGUMENTS:
!       Temperature_AD:  AD Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(INOUT)
!
!------------------------------------------------------------------------------
  SUBROUTINE Compute_Predictors_zssmis_AD(Temperature,   &
                                          Be,            &
                                          CosBK,         &
                                          Predictor_AD,  &
                                          Temperature_AD )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Be
    REAL(fp), INTENT( IN ) :: CosBK
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor_AD
    REAL(fp), INTENT( INOUT ) :: Temperature_AD(:)

    ! LOCAL
    REAL(fp) :: Be2, CosBK2, OneOverT, OneOverT_AD
    INTEGER  :: k

    Be2         = Be  * Be
    CosBK2     = CosBK * CosBK

    DO k = 1, Predictor_AD%n_Layers
      ! Predictors associated Temperature
      OneOverT = 300.0_fp / Temperature(k)

      OneOverT_AD = Predictor_AD%X(k, 1,  1) + &
                    Predictor_AD%X(k, 2,  1)*CosBK2 + &
                    Predictor_AD%X(k, 3,  1) / Be + &
                    Predictor_AD%X(k, 4,  1) * CosBK / Be + &
                    Predictor_AD%X(k, 5,  1) * CosBK / Be2
      Temperature_AD(k) = Temperature_AD(k) - &
                     (OneOverT / Temperature(k)) * OneOverT_AD
    END DO

    ! Constant predictor
    Predictor_AD%X(:, :,  1)  = ZERO

    Predictor_AD%n_CP(1) = MAX_N_PREDICTORS_ZSSMIS

  END SUBROUTINE Compute_Predictors_zssmis_AD

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zamsua
!
! PURPOSE:
!       Subroutine to compute predictors for the ZAMSUA sensor (a virtual sensor
!       with AMSUA channel 14)
!
! CALLING SEQUENCE:
!       CALL  Compute_Predictors_zamsua(Temperature,     &
!                                       Ref_Temperature, &
!                                       Be,            &
!                                       CosBK,         &
!                                       Secang,        &
!                                       Predictor )
!
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!   Ref_Temperature:     Reference temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!         Be    :        Earth magnetic filed strength
!                        UNITS:      Guass (range 0.2 - 0.7)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  scalar
!                        ATTRIBUTES: INTENT(IN)
!
!         CosBK :        Cosine of the angle between the Earth magnetic
!                        field and the electromagnetic wave propagation
!                        direction
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!             Secang  :  Secant of the zenith angle profile
!                        UNITS:      N/A
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Predictor:      Predictor structure
!                       UNITS:      N/A
!                       TYPE:       TYPE(ODPS_Predictor_type)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!------------------------------------------------------------------------------

  SUBROUTINE Compute_Predictors_zamsua(Temperature,     &
                                       Ref_Temperature, &
                                       Be,              &
                                       CosBK,           &
                                       Secang,          &
                                       Predictor )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Ref_Temperature(:)
    REAL(fp), INTENT( IN ) :: Be
    REAL(fp), INTENT( IN ) :: CosBK
    REAL(fp), INTENT( IN ) :: Secang(:)
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor

    ! LOCAL
    REAL(fp) :: Be3,  CosBK2, CosBK2Be2, tk
    INTEGER  :: k

    Be3         = Be*Be*Be
    CosBK2     = CosBK*CosBK
    CosBK2Be2  = CosBK2*Be*Be

    DO k = 1, Predictor%n_Layers
      tk = Temperature(k)/Ref_Temperature(k)
      Predictor%X(k, 1,  1)  = Secang(k)
      Predictor%X(k, 2,  1)  = tk
      Predictor%X(k, 3,  1)  = tk*tk
      Predictor%X(k, 4,  1)  = CosBK2
      Predictor%X(k, 5,  1)  = Be*Secang(k)
      Predictor%X(k, 6,  1)  = Be3
      Predictor%X(k, 7,  1)  = CosBK2Be2*Secang(k)
    END DO

    Predictor%n_CP(1) = MAX_N_PREDICTORS_ZAMSUA

    Predictor%Secant_Zenith = Secang

  END SUBROUTINE Compute_Predictors_zamsua

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zamsua_TL
!
! PURPOSE:
!       Subroutine to compute TL predictors for the ZAMSUA sensor (a virtual sensor
!       with AMSUA channel 14)
!
! CALLING SEQUENCE:
!
!       CALL Compute_Predictors_zamsua_TL(Temperature,     &
!                                         Ref_Temperature, &
!                                         Temperature_TL,&
!                                         Predictor_TL )
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!    RefTemperature:     Reference temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:  TL Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Predictor_TL:   TL Predictor structure
!                       UNITS:      N/A
!                       TYPE:       TYPE(ODPS_Predictor_type)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!------------------------------------------------------------------------------

  SUBROUTINE Compute_Predictors_zamsua_TL(Temperature,      &
                                          Ref_Temperature,  &
                                          Temperature_TL,   &
                                          Predictor_TL )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Ref_Temperature(:)
    REAL(fp), INTENT( IN ) :: Temperature_TL(:)
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor_TL

    ! LOCAL
    REAL(fp) :: tk, tk_TL
    INTEGER  :: k

    DO k = 1, Predictor_TL%n_Layers
      tk = Temperature(k)/Ref_Temperature(k)
      tk_TL = Temperature_TL(k)/Ref_Temperature(k)
      Predictor_TL%X(k, 1,  1)  = ZERO
      Predictor_TL%X(k, 2,  1)  = tk_TL
      Predictor_TL%X(k, 3,  1)  = TWO*tk*tk_TL
      Predictor_TL%X(k, 4,  1)  = ZERO
      Predictor_TL%X(k, 5,  1)  = ZERO
      Predictor_TL%X(k, 6,  1)  = ZERO
      Predictor_TL%X(k, 7,  1)  = ZERO
    END DO

    Predictor_TL%n_CP(1) = MAX_N_PREDICTORS_ZAMSUA

  END SUBROUTINE Compute_Predictors_zamsua_TL

!------------------------------------------------------------------------------
!
! NAME:
!       Compute_Predictors_zamsua_AD
!
! PURPOSE:
!       Subroutine to compute AD predictors for the ZAMSUA sensor (a virtual sensor
!       with AMSUA channel 14)
!
! CALLING SEQUENCE:
!
!        CALL Compute_Predictors_zamsua_AD(Temperature,     &
!                                          Ref_Temperature, &
!                                          Predictor_AD,  &
!                                          Temperature_AD )
! INPUT ARGUMENTS:
!
!       Temperature:     Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!    Ref_Temperature:    Reference temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(IN)
!
!       Predictor_AD:    AD Predictor structure
!                        UNITS:      N/A
!                        TYPE:       TYPE(ODPS_Predictor_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(INOUT)
!
! OUTPUT ARGUMENTS:
!       Temperature_AD:  AD Temperature profile
!                        UNITS:      K
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1(n_Layers) array
!                        ATTRIBUTES: INTENT(INOUT)
!
!------------------------------------------------------------------------------
  SUBROUTINE Compute_Predictors_zamsua_AD(Temperature,    &
                                          Ref_Temperature,&
                                          Predictor_AD,  &
                                          Temperature_AD )
    REAL(fp), INTENT( IN ) :: Temperature(:)
    REAL(fp), INTENT( IN ) :: Ref_Temperature(:)
    TYPE(ODPS_Predictor_type), INTENT( INOUT ) :: Predictor_AD
    REAL(fp), INTENT( INOUT ) :: Temperature_AD(:)

    ! LOCAL
    REAL(fp) :: tk, tk_AD
    INTEGER  :: k

    DO k = Predictor_AD%n_Layers, 1, -1
      tk = Temperature(k)/Ref_Temperature(k)

      tk_AD = TWO*tk*Predictor_AD%X(k, 3,  1)
      tk_AD = tk_AD + Predictor_AD%X(k, 2,  1)
      Temperature_AD(k) = Temperature_AD(k) + tk_AD/Ref_Temperature(k)
      Predictor_AD%X(k, :,  1) = ZERO
    END DO

    Predictor_AD%n_CP(1) = MAX_N_PREDICTORS_ZAMSUA

  END SUBROUTINE Compute_Predictors_zamsua_AD

END MODULE ODZeeman_Predictor


      subroutine reader_input(inputfile,workdir)
************************************************************************
*   Routine to read in the file input.DAT, which is a consolidated     *
*   form of all the input files and new to version 3.4 of MCFM         *
************************************************************************
      implicit none
      include 'constants.f'
      include 'debug.f'
      include 'new_pspace.f'
      include 'couple.f'
      include 'part.f'
      include 'virtonly.f'
      include 'realonly.f'
      include 'noglue.f'
      include 'realwt.f'
      include 'lc.f'
      include 'cutoff.f'
      include 'maxwt.f'
      include 'masses.f'
      include 'process.f'
      include 'scale.f'
      include 'facscale.f'
      include 'dynamicscale.f'
      include 'zerowidth.f'
      include 'removebr.f'
      include 'flags.f'
      include 'clustering.f'
      include 'anomcoup.f'
      include 'gridinfo.f'
      include 'verbose.f'
      include 'limits.f'
      include 'werkdir.f'
      include 'jetcuts.f'
      include 'leptcuts.f'
      include 'lhapdf.f'
      include 'alfacut.f'
      include 'betacut.f'
      include 'pdlabel.f'
      include 'qcdcouple.f'
      include 'nlooprun.f'
      include 'initialscales.f'
      include 'stopscales.f'
      include 'vanillafiles.f'
      include 'frag.f'
      include 'outputoptions.f'
      include 'outputflags.f'
      include 'breit.f'
      include 'anomHiggs.f'
      include 'anom_higgs.f'
      include 'vdecayid.f'
      include 'runstring.f'
      include 'energy.f'
      include 'nproc.f'
c--- APPLgrid - flag using grid
c      include 'ptilde.f'
c      include 'APPLinclude.f'
c--- APPLgrid - end
      character*72 workdir,inputfile
      character*90 line
      logical spira,dryrun,makecuts,creategrid
      integer nmin,nmax,ii
      integer ih1,ih2,itmx1,itmx2,ncall1,ncall2,idum,origij
      integer NPTYPE,NGROUP,NSET
      double precision rtsmin,factor
      double precision mbbmin,mbbmax,Mwmin,Mwmax
      double precision Rcut
      logical technicalincluded
      double precision ran2,randummy
      double precision cmass,bmass
      double precision alphas

      common/spira/spira
      common/nmin/nmin
      common/nmax/nmax
      common/rtsmin/rtsmin

      common/density/ih1,ih2
      common/iterat/itmx1,ncall1,itmx2,ncall2
      common/ranno/idum
      common/dryrun/dryrun

      common/pdflib/NPTYPE,NGROUP,NSET

      common/Rcut/Rcut
      common/makecuts/makecuts

      common/qmass/cmass,bmass

      common/origij/origij

      save /ranno/

      data cttH/1.0d0/
      data cWWH/1.0d0/

      verbose=.true.

      werkdir=workdir
c--- work out the name of the input file and open it

      write(6,*) '* Using input file named ',inputfile

      open(unit=20,file=inputfile,status='old',err=999)
      call checkversion(20,inputfile)

c--- read-in the user inputs

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- flags for the mode of MCFM
      read(20,*) nevtrequested
      if (verbose) call writeinput(6,' * ',' ','nevtrequested')
      read(20,*) creatent
      if (verbose) call writeinput(6,' * ',' ','creatent')
      read(20,*) skipnt
      if (verbose) call writeinput(6,' * ',' ','skipnt')
      read(20,*) dswhisto
      if (verbose) call writeinput(6,' * ',' ','dswhisto')
c--- APPLgrid - added to read flag for grids
       read(20,*) creategrid
       if (verbose) call writeinput(6,' * ',' ','creategrid')
c--- APPLgrid - end
      read(20,*) writetop
      if (verbose) call writeinput(6,' * ',' ','writetop')
      read(20,*) writedat
      if (verbose) call writeinput(6,' * ',' ','writedat')
      read(20,*) writegnu
      if (verbose) call writeinput(6,' * ',' ','writegnu')
      read(20,*) writeroot
      if (verbose) call writeinput(6,' * ',' ','writeroot')
      read(20,*) writepwg
      if (verbose) call writeinput(6,' * ',' ','writepwg')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- general options

c--- read in whole line for nproc
      read(20,99) line
      ii=index(line,'.')
      if (ii .gt. 0) then
        vdecayid=.true.
c------ special string present to specify V decays
        read(line(1:ii-1),*) nproc
        v34id=line(ii+1:ii+2)
        v56id=line(ii+3:ii+4)
c        write(6,*) 'special nproc=',nproc
c        write(6,*) 'v34id',v34id
c        write(6,*) 'v56id',v56id
c        stop
c------ normal case
      else
        vdecayid=.false.
        read(line,*) nproc
      endif
      if (verbose) call writeinput(6,' * ',' ','nproc')
      read(20,*) part
      if (verbose) call writeinput(6,' * ',' ','part')
      read(20,*) runstring
      if (verbose) call writeinput(6,' * ',' ','runstring')
      read(20,*) sqrts
      if (verbose) call writeinput(6,' * ',' ','sqrts')
      read(20,*) ih1
      if (verbose) call writeinput(6,' * ',' ','ih1')
      read(20,*) ih2
      if (verbose) call writeinput(6,' * ',' ','ih2')
      read(20,*) hmass
      if (verbose) call writeinput(6,' * ',' ','hmass')
      read(20,*) scale
      initscale=scale
      if (verbose) call writeinput(6,' * ',' ','scale')
      read(20,*) facscale
      initfacscale=facscale
      if (verbose) call writeinput(6,' * ',' ','facscale')

      initrenscale_L=0d0
      initfacscale_L=0d0
      initrenscale_H=0d0
      initfacscale_H=0d0
c--- catch special scale choices for stop+b process
      if (((nproc .ge. 231) .and. (nproc .le. 240)) .and.
     .     (scale .eq. 0d0) .and. (facscale .eq. 0d0)) then
        read(20,*) initrenscale_L
      renscale_L=initrenscale_L
        if (verbose) call writeinput(6,' * ',' ','renscale_L')
        read(20,*) initfacscale_L
      facscale_L=initfacscale_L
        if (verbose) call writeinput(6,' * ',' ','facscale_L')
        read(20,*) initrenscale_H
      renscale_H=initrenscale_H
        if (verbose) call writeinput(6,' * ',' ','renscale_H')
        read(20,*) initfacscale_H
      facscale_H=initfacscale_H
        if (verbose) call writeinput(6,' * ',' ','facscale_H')
      scale=initrenscale_H
      facscale=initfacscale_H
      endif

      read(20,*) dynstring
      if (verbose) call writeinput(6,' * ',' ','dynamicscale')
      read(20,*) zerowidth
      if (verbose) call writeinput(6,' * ',' ','zerowidth')
      read(20,*) removebr
      if (verbose) call writeinput(6,' * ',' ','removebr')
      read(20,*) itmx1
      if (verbose) call writeinput(6,' * ',' ','itmx1')
      read(20,*) ncall1
      if (verbose) call writeinput(6,' * ',' ','ncall1')
      read(20,*) itmx2
      if (verbose) call writeinput(6,' * ',' ','itmx2')
      read(20,*) ncall2
      if (verbose) call writeinput(6,' * ',' ','ncall2')
      read(20,*) origij
      if (verbose) call writeinput(6,' * ',' ','ij')
      read(20,*) dryrun
      if (verbose) call writeinput(6,' * ',' ','dryrun')
      read(20,*) Qflag
      if (verbose) call writeinput(6,' * ',' ','Qflag')
      read(20,*) Gflag
      if (verbose) call writeinput(6,' * ',' ','Gflag')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- heavy quark masses
      read(20,*) mt
      if (verbose) call writeinput(6,' * ',' ','top mass')
      read(20,*) mb
      if (verbose) call writeinput(6,' * ',' ','bottom mass')
      read(20,*) mc
      if (verbose) call writeinput(6,' * ',' ','charm mass')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- pdf options
      read(20,*) pdlabel
      if (verbose) call writeinput(6,' * ',' ','pdlabel')
      read(20,*) NGROUP
      if (verbose) call writeinput(6,' * ',' ','NGROUP')
      read(20,*) NSET
      if (verbose) call writeinput(6,' * ',' ','NSET')
      read(20,*) PDFname
      if (verbose) call writeinput(6,' * ',' ','LHAPDF group')
      read(20,*) PDFmember
      if (verbose) call writeinput(6,' * ',' ','LHAPDF set')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- jets and cuts options
      read(20,*) Mwmin
      wsqmin=Mwmin**2
      if (verbose) call writeinput(6,' * ',' ','m34min')
      read(20,*) Mwmax
      if (Mwmax .gt. sqrts) Mwmax=sqrts ! physical cap on m34max
      wsqmax=Mwmax**2
      if (verbose) call writeinput(6,' * ',' ','m34max')
      read(20,*) mbbmin
      bbsqmin=mbbmin**2
      if (verbose) call writeinput(6,' * ',' ','m56min')
      read(20,*) mbbmax
      if (mbbmax .gt. sqrts) Mbbmax=sqrts ! physical cap on m56max
      bbsqmax=mbbmax**2
      if (verbose) call writeinput(6,' * ',' ','m56max')
      read(20,*) m3456min
      if (verbose) call writeinput(6,' * ',' ','m3456min')
      read(20,*) m3456max
      if (verbose) call writeinput(6,' * ',' ','m3456max')
      read(20,*) inclusive
      if (verbose) call writeinput(6,' * ',' ','inclusive')
      read(20,*) algorithm
      if (verbose) call writeinput(6,' * ',' ','algorithm')
      read(20,*) ptjetmin
      if (verbose) call writeinput(6,' * ',' ','ptjetmin')
      read(20,*) etajetmin
      if (verbose) call writeinput(6,' * ',' ','etajetmin')
      read(20,*) etajetmax
      if (verbose) call writeinput(6,' * ',' ','etajetmax')
      read(20,*) Rcut
      if (verbose) call writeinput(6,' * ',' ','Rcut')
      read(20,*) makecuts
      if (verbose) call writeinput(6,' * ',' ','makecuts')
      read(20,*) leptpt
      if (verbose) call writeinput(6,' * ',' ','leptpt')
      read(20,*) leptrap
      if (verbose) call writeinput(6,' * ',' ','leptrap')
      read(20,*) leptveto1min,leptveto1max
      if (verbose) call writeinput(6,' * ',' ','leptveto')
      read(20,*) misspt
      if (verbose) call writeinput(6,' * ',' ','misspt')
      read(20,*) leptpt2
      if (verbose) call writeinput(6,' * ',' ','leptpt2')
      read(20,*) leptrap2
      if (verbose) call writeinput(6,' * ',' ','leptrap2')
      read(20,*) leptveto2min,leptveto2max
      if (verbose) call writeinput(6,' * ',' ','leptveto2')
      read(20,*) mtrans34cut
      if (verbose) call writeinput(6,' * ',' ','mtrans34cut')
      read(20,*) Rjlmin
      if (verbose) call writeinput(6,' * ',' ','Rjlmin')
      read(20,*) Rllmin
      if (verbose) call writeinput(6,' * ',' ','Rllmin')
      read(20,*) delyjjmin
      if (verbose) call writeinput(6,' * ',' ','delyjjmin')
      read(20,*) jetsopphem
      if (verbose) call writeinput(6,' * ',' ','jetsopphem')
      read(20,*) lbjscheme
      if (verbose) call writeinput(6,' * ',' ','lbjscheme')
      read(20,*) ptbjetmin
      if (verbose) call writeinput(6,' * ',' ','ptbjetmin')
      read(20,*) etabjetmax
      if (verbose) call writeinput(6,' * ',' ','etabjetmax')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- settings for photon processes
      read(20,*) frag
      if (verbose) call writeinput(6,' * ',' ','frag')
      read(20,*) fragset
      if (verbose) call writeinput(6,' * ',' ','fragset')
      read(20,*) frag_scale
      frag_scalestart=frag_scale
      if (verbose) call writeinput(6,' * ',' ','frag_scale')
      read(20,*) gammpt
      if (verbose) call writeinput(6,' * ',' ','gammpt')
      read(20,*) gammrap
      if (verbose) call writeinput(6,' * ',' ','gammrap')
      read(20,*) gammpt2
      if (verbose) call writeinput(6,' * ',' ','gammpt2')
      read(20,*) gammpt3
      if (verbose) call writeinput(6,' * ',' ','gammpt3')
      read(20,*) Rgalmin
      if (verbose) call writeinput(6,' * ',' ','Rgalmin')
      read(20,*) Rgagamin
      if (verbose) call writeinput(6,' * ',' ','Rgagamin')
      read(20,*) Rgajetmin
      if (verbose) call writeinput(6,' * ',' ','Rgajetmin')
      read(20,*) cone_ang
      if (verbose) call writeinput(6,' * ',' ','cone_ang')
      read(20,*) epsilon_h
      if (verbose) call writeinput(6,' * ',' ','epsilon_h')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- anomalous couplings
      read(20,*) delg1_z
      if (verbose) call writeinput(6,' * ',' ','delg1_z')
      read(20,*) delk_z
      if (verbose) call writeinput(6,' * ',' ','delk_z')
      read(20,*) delk_g
      if (verbose) call writeinput(6,' * ',' ','delk_g')
      read(20,*) lambda_z
      if (verbose) call writeinput(6,' * ',' ','lambda_z')
      read(20,*) lambda_g
      if (verbose) call writeinput(6,' * ',' ','lambda_g')
      read(20,*) h1Z
      if (verbose) call writeinput(6,' * ',' ','h1Z')
      read(20,*) h1gam
      if (verbose) call writeinput(6,' * ',' ','h1gam')
      read(20,*) h2Z
      if (verbose) call writeinput(6,' * ',' ','h2Z')
      read(20,*) h2gam
      if (verbose) call writeinput(6,' * ',' ','h2gam')
      read(20,*) h3Z
      if (verbose) call writeinput(6,' * ',' ','h3Z')
      read(20,*) h3gam
      if (verbose) call writeinput(6,' * ',' ','h3gam')
      read(20,*) h4Z
      if (verbose) call writeinput(6,' * ',' ','h4Z')
      read(20,*) h4gam
      if (verbose) call writeinput(6,' * ',' ','h4gam')
      read(20,*) tevscale
      if (verbose) call writeinput(6,' * ',' ','tevscale')

      if ( nproc .ge. 550 .and. nproc .le. 557 ) then
         if (verbose) call writeinput(6,' * ',' ','cttH')
         if (verbose) call writeinput(6,' * ',' ','cWWH')
      endif

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- width of the Higgs
      read(20,*) hwidth_ratio
      if (verbose) call writeinput(6,' * ',' ','hwidth_ratio')

      if (verbose) write(6,*)
      read(20,99) line
c--- write-out comment line
      read(20,99) line
      if (verbose) write(6,*) '* ',line
c--- grid information
      read(20,*) readin
      if (verbose) call writeinput(6,' * ',' ','readin')
      read(20,*) writeout
      if (verbose) call writeinput(6,' * ',' ','writeout')
      read(20,*) ingridfile
      if (verbose) call writeinput(6,' * ',' ','ingridfile')
      read(20,*) outgridfile
      if (verbose) call writeinput(6,' * ',' ','outgridfile')

      if (verbose) write(6,*)

c--- check if the contents of technical.DAT are included here
c--- (the default behaviour going forward)
      technicalincluded=.false.

      read(20,99,end=88) line
      read(20,99,end=88) line
c      write(6,*) line
      if (line(2:10) .ne. 'Technical') goto 88
      technicalincluded=.true.

   88 continue

c--- if the contents of technical.DAT are not included, close the input
c--- file and open technical.DAT instead; otherwise continue on
      if (technicalincluded .eqv. .false.) then
        close(20)
        open(unit=20,file='technical.DAT',status='old',err=999)
        call checkversion(20,'technical.DAT')
      endif

      if (verbose) write(6,*) '* [Technical parameters that'//
     .                        ' should not normally be changed]'
      if (verbose) write(6,*)

c---- read-in the technical parameters

      read(20,*) debug
      if (verbose) call writeinput(6,' * ',' ','debug')
      read(20,*) verbose
      if (verbose) call writeinput(6,' * ',' ','verbose')
      read(20,*) new_pspace
      if (verbose) call writeinput(6,' * ',' ','new_pspace')
      read(20,*) virtonly
      if (verbose) call writeinput(6,' * ',' ','virtonly')
      read(20,*) realonly
      if (verbose) call writeinput(6,' * ',' ','realonly')
      read(20,*) spira
      if (verbose) call writeinput(6,' * ',' ','spira')
      read(20,*) noglue
      if (verbose) call writeinput(6,' * ',' ','noglue')
      read(20,*) ggonly
      if (verbose) call writeinput(6,' * ',' ','ggonly')
      read(20,*) gqonly
      if (verbose) call writeinput(6,' * ',' ','gqonly')
      read(20,*) omitgg
      if (verbose) call writeinput(6,' * ',' ','omitgg')
      read(20,*) vanillafiles
      if (verbose) call writeinput(6,' * ',' ','vanillafiles')
      read(20,*) nmin
      if (verbose) call writeinput(6,' * ',' ','nmin')
      read(20,*) nmax
      if (verbose) call writeinput(6,' * ',' ','nmax')
      read(20,*) clustering
      if (verbose) call writeinput(6,' * ',' ','clustering')
      read(20,*) realwt
      if (verbose) call writeinput(6,' * ',' ','realwt')
      read(20,*) colourchoice
      if (verbose) call writeinput(6,' * ',' ','colourchoice')
      read(20,*) rtsmin
      if (verbose) call writeinput(6,' * ',' ','rtsmin')
      read(20,*) cutoff
      if (verbose) call writeinput(6,' * ',' ','cutoff')
      read(20,*) aii
      if (verbose) call writeinput(6,' * ',' ','aii')
      read(20,*) aif
      if (verbose) call writeinput(6,' * ',' ','aif')
      read(20,*) afi
      if (verbose) call writeinput(6,' * ',' ','afi')
      read(20,*) aff
      if (verbose) call writeinput(6,' * ',' ','aff')
      read(20,*) bfi
      if (verbose) call writeinput(6,' * ',' ','bfi')
      read(20,*) bff
      if (verbose) call writeinput(6,' * ',' ','bff')
      if (verbose) write(6,*)
      close(unit=20)

      if ((etajetmin .lt. 0d0) .or. (etajetmax .lt. 0d0)) then
        write(6,*) 'etajetmin and etajetmax are absolute values,'
      write(6,*) ' please reset to a positive value.'
      stop
      endif

c      if     (index(runstring,'mc1.3') .gt. 0) then
c        mc=1.3d0
c      mcsq=mc**2
c      elseif (index(runstring,'mc1.4') .gt. 0) then
c        mc=1.4d0
c      mcsq=mc**2
c      elseif (index(runstring,'mc1.5') .gt. 0) then
c        mc=1.5d0
c      mcsq=mc**2
c      endif

c      if (runstring(1:3) .eq. 'mlm') then
c        write(6,*) 'WARNING: cross sections divided by Ecm**2'
c      write(6,*)
c      endif

c---  create logical variable dynamicscale for use in other routines
      if (  (dynstring .eq. 'no') .or. (dynstring .eq. '.false.')
     & .or. (dynstring .eq. 'none') ) then
         dynamicscale=.false.
      else
         dynamicscale=.true.
      endif

c--- print warning messages if some parton fluxes are not included
      if (noglue) then
        write(6,*) 'WARNING: no gluon contribution included in PDF'
      write(6,*)
      endif
      if (ggonly) then
        write(6,*) 'WARNING: only gluon-gluon flux included'
      write(6,*)
      endif
      if (gqonly) then
        write(6,*) 'WARNING: only gluon-quark flux included'
      write(6,*)
      endif
      if (omitgg) then
        write(6,*) 'WARNING: no gluon-gluon contribution included'
      write(6,*)
      endif

c--- assign squared masses for b- and c-quarks
      if (abs(mb) .gt. 1d-8) then
        mbsq=mb**2
      else
        mbsq=4.75d0**2
      endif
      if (abs(mc) .gt. 1d-8) then
        mcsq=mc**2
      else
        mcsq=1.5d0**2
      endif

c--- set-up the variables for the process we wish to consider
      call chooser

c--- set-up the random number generator with a negative seed
      idum=-abs(origij)
      randummy=ran2()

c--- initialize masses for alpha_s routine
      cmass=dsqrt(mcsq)
      bmass=dsqrt(mbsq)

c--- E-M gauge invariance requires that delg1_g=0
      delg1_g=0d0

c--- check that we have a valid value of 'part'
      if ( (part .ne. 'lord') .and. (part .ne. 'real') .and.
     .     (part .ne. 'virt') .and. (part .ne. 'tota') ) then
        if    ( (part .eq. 'todk') .and.
     .          ((case .eq. 'bq_tpq') .or. (case .eq. 't_bbar')
     .      .or. (case .eq. 'W_twdk') .or. (case .eq. 'tt_bbl')
     .      .or. (case .eq. 'tt_bbh') .or. (case .eq. '4ftwdk')
     .      .or. (case .eq. 'HWW2lq') .or. (case .eq. 'qq_ttw')
     .      .or. (case .eq. 'WWqqbr') .or. (case .eq. 'tt_bbu')) ) then
c--- this is an allowed combination
        elseif ( (part .eq. 'frag') .and.
     .          ((case .eq. 'Wgamma') .or. (case .eq. 'Zgamma')
     &      .or. (case .eq. 'gamgam') .or. (case .eq. 'dirgam')
     &      .or. (case .eq. 'dm_gam')
     &      .or. (case .eq. 'gmgmjt') .or .(case .eq. 'trigam')
     &      .or. (case .eq. 'fourga')
     &      .or. (case .eq. 'Z_2gam') .or. (case .eq. 'Zgajet')
     &      .or. (case .eq. 'W_2gam')) ) then
c--- this is an allowed combination
        else
          write(6,*) 'part=',part,' is not a valid option'
          write(6,*) 'for this process number.'
          stop
        endif
      endif

c--- check that we are not trying to calculate radiation in decay at LO
      if    ( (part .eq. 'lord') .and.
     &       ((case .eq. 'WWqqdk') .or. (case .eq. 'HWWdkW')
     &   .or. (case .eq. 'tt_ldk') .or. (case .eq. 'tt_udk')
     &   .or. (case .eq. 'tt_hdk') .or. (case .eq. 'tthWdk')
     &   .or. (case .eq. 'ttdkay') .or. (case .eq. 'Wtdkay')
     &   .or. (case .eq. 'dk_4ft') .or. (case .eq. 'ttwldk')) ) then
          write(6,*) 'This process number cannot be used for'
          write(6,*) 'a LO calculation.'
          stop
      endif
c--- set up the default choices of static scale, if required
      if (scale .lt. 0d0) then
      if     (scale .eq. -2d0) then
        factor=0.25d0
      elseif (scale .eq. -3d0) then
        factor=0.5d0
      elseif (scale .eq. -4d0) then
        factor=0.75d0
      elseif (scale .eq. -5d0) then
        factor=1d0
      elseif (scale .eq. -6d0) then
        factor=2d0
      elseif (scale .eq. -7d0) then
        factor=4d0
        else
        factor=1d0
      endif
        if ((n2+n3 .ne. 0) .or. (case .eq. 'tt_tot')) then
c--- special case for t-tbar production
        if (case .eq. 'tt_tot') then
          scale=factor*mt
c--- special cases where Higgs mass is neither mass2 nor mass3
        elseif ((case(1:1) .eq. 'H') .or. (case .eq. 'WHbbar')
     &     .or. (case .eq. 'ZHbbar') .or. (case .eq. 'qq_Hqq')) then
          scale=factor*hmass
        else
          scale=factor*(dfloat(n2)*mass2+dfloat(n3)*mass3)/dfloat(n2+n3)
        endif
        as=alphas(scale,amz,nlooprun)
        ason2pi=as/twopi
        ason4pi=as/fourpi
        gsq=fourpi*as
        musq=scale**2
        write(6,*)
        write(6,*)'************* Strong coupling, alpha_s  ************'
        write(6,*)'*                                                  *'
        write(6,49)'alpha_s (scale)',gsq/fourpi
        write(6,49)'alpha_s (zmass)',amz
        write(6,50)' (using ',nlooprun,'-loop running of alpha_s)'
        write(6,*)'****************************************************'
        write(6,*)
        write(6,*)'****************************************************'
        write(6,76) scale
        write(6,*)'****************************************************'
        else
        write(6,*) 'Invalid choice of renormalization scale!'
        stop
        endif
      endif
      if (facscale .lt. 0d0) then
      if     (facscale .eq. -2d0) then
        factor=0.25d0
      elseif (facscale .eq. -3d0) then
        factor=0.5d0
      elseif (facscale .eq. -4d0) then
        factor=0.75d0
      elseif (facscale .eq. -5d0) then
        factor=1d0
      elseif (facscale .eq. -6d0) then
        factor=2d0
      elseif (facscale .eq. -7d0) then
        factor=4d0
        else
        factor=1d0
      endif
        if ((n2+n3 .ne. 0) .or. (case .eq. 'tt_tot')) then
c--- special case for t-tbar production
        if (case .eq. 'tt_tot') then
          facscale=factor*mt
c--- special cases where Higgs mass is neither mass2 nor mass3
        elseif ((case(1:1) .eq. 'H') .or. (case .eq. 'WHbbar')
     &     .or. (case .eq. 'ZHbbar') .or. (case .eq. 'qq_Hqq')) then
          facscale=factor*hmass
        else
          facscale=factor*
     &             (dfloat(n2)*mass2+dfloat(n3)*mass3)/dfloat(n2+n3)
        endif
        write(6,*)
        write(6,*)'****************************************************'
        write(6,77) facscale
        write(6,*)'****************************************************'
       else
        write(6,*) 'Invalid choice of factorization scale!'
        stop
        endif
      endif

      return

   49 format(' *  ',a20,f12.8,16x,'*')
   50 format(' *  ',6x,a8,i1,a25,8x,'*')
   76 format(' *      Renormalization scale =',f7.2,'              *')
   77 format(' *        Factorization scale =',f7.2,'              *')
   99 format(a90)

  999 continue
      write(6,*) 'Problem reading ',inputfile
      write(6,*)
      write(6,*) 'Refer to documentation for the format of input.DAT'
      write(6,*)
      stop

      end