*IF DEF,RECON INMOSES1.2
C *****************************COPYRIGHT****************************** INMOSES1.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. INMOSES1.4
C INMOSES1.5
C Use, duplication or disclosure of this code is subject to the INMOSES1.6
C restrictions as set forth in the contract. INMOSES1.7
C INMOSES1.8
C Meteorological Office INMOSES1.9
C London Road INMOSES1.10
C BRACKNELL INMOSES1.11
C Berkshire UK INMOSES1.12
C RG12 2SZ INMOSES1.13
C INMOSES1.14
C If no contract has been raised with this copy of the code, the use, INMOSES1.15
C duplication or disclosure of it is strictly prohibited. Permission INMOSES1.16
C to do so must first be obtained in writing from the Head of Numerical INMOSES1.17
C Modelling at the above address. INMOSES1.18
C ******************************COPYRIGHT****************************** INMOSES1.19
SUBROUTINE INIT_MOSES(P_FIELD,SM_LEVELS,ST_LEVELS,FIXHD, 1,27INMOSES1.20
& LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP, INMOSES1.21
& LAND_POINTS,NFTOUT,N_TYPES,PP_ITEMC,PP_POS, INMOSES1.22
*CALL ARGPPX 
INMOSES1.23
& D1_SMCL,D1_TDEEP,D1_VSAT,D1_BEXP,D1_SATHH) INMOSES1.24
! Subroutine arguments INMOSES1.25
INMOSES1.26
! Scalar arguments with intent(IN) : INMOSES1.27
INTEGER P_FIELD !Length of field INMOSES1.28
INTEGER SM_LEVELS !Number of soil moisture levels INMOSES1.29
INTEGER ST_LEVELS !Number of soil temperature levels INMOSES1.30
INTEGER LEN1_LOOKUP !1st dim. of lookup table INMOSES1.31
INTEGER LEN2_LOOKUP !2nd dim. of lookup table INMOSES1.32
INTEGER LAND_POINTS !Number of land points INMOSES1.33
INTEGER NFTOUT !Output unit number INMOSES1.34
INTEGER N_TYPES !Number of different field types INMOSES1.35
! Array arguments with intent(IN) : INMOSES1.36
INTEGER FIXHD(*) !Fixed length header INMOSES1.37
INTEGER LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) INMOSES1.38
!Lookup table INMOSES1.39
INTEGER PP_ITEMC(N_TYPES) !Item code |For each field INMOSES1.40
INTEGER PP_POS(N_TYPES) !Position |type on output file INMOSES1.41
REAL D1_SMCL(P_FIELD,SM_LEVELS) ! INMOSES1.42
REAL D1_TDEEP(P_FIELD,ST_LEVELS) ! INMOSES1.43
REAL D1_VSAT(P_FIELD) !Work space INMOSES1.44
REAL D1_BEXP(P_FIELD) ! INMOSES1.45
REAL D1_SATHH(P_FIELD) ! INMOSES1.46
! External subroutines called: INMOSES1.47
EXTERNAL LOCATE,ABORT_IO,READFLDS,ABORT INMOSES1.48
! Local scalars: INMOSES1.49
INTEGER ICODE !Error code INMOSES1.50
INTEGER POS !Position indicator INMOSES1.51
CHARACTER*256 CMESSAGE !Error message if ICODE > 0 INMOSES1.52
! Local arrays: INMOSES1.53
REAL D1_STHU(P_FIELD,SM_LEVELS) !Work space INMOSES1.54
REAL D1_STHF(P_FIELD,SM_LEVELS) ! INMOSES1.55
! Comdecks: INMOSES1.56
*CALL CSUBMODL INMOSES1.57
*CALL CPPXREF INMOSES1.58
*CALL PPXLOOK INMOSES1.59
*CALL SOIL_THICK INMOSES1.60
!---------------------------------------------------------------------- INMOSES1.61
! Locate fields in output dump that are needed to INMOSES1.62
! initialise soil moisture fractions INMOSES1.63
WRITE (6,*) ' ' INMOSES1.64
WRITE (6,*) ' No soil moisture fraction in input dump' INMOSES1.65
WRITE (6,*) ' Soil moisture fraction being initialised' INMOSES1.66
CALL LOCATE (9,PP_ITEMC,N_TYPES,POS) INMOSES1.67
IF (POS.EQ.0) THEN INMOSES1.68
CMESSAGE = INMOSES1.69
& 'INIT_MOSES: Problem with initialising STHU' INMOSES1.70
WRITE (6,*) 'SMC in layers not found in output dump' INMOSES1.71
CALL ABORT INMOSES1.72
ELSE INMOSES1.73
CALL READFLDS (NFTOUT,SM_LEVELS,PP_POS(POS), INMOSES1.74
& LOOKUP,LEN1_LOOKUP, INMOSES1.75
& D1_SMCL,P_FIELD,FIXHD, INMOSES1.76
*CALL ARGPPX INMOSES1.77
& ICODE,CMESSAGE) INMOSES1.78
IF (ICODE.GT.0) THEN INMOSES1.79
WRITE (6,*) ' Problem with reading SMCL field' INMOSES1.80
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.81
END IF INMOSES1.82
END IF INMOSES1.83
CALL LOCATE (20,PP_ITEMC,N_TYPES,POS) INMOSES1.84
IF (POS.EQ.0) THEN INMOSES1.85
CMESSAGE = INMOSES1.86
& 'INIT_MOSES: Problem with initialising STHU' INMOSES1.87
WRITE (6,*) 'TDEEP in layers not found in output dump' INMOSES1.88
CALL ABORT INMOSES1.89
ELSE INMOSES1.90
CALL READFLDS (NFTOUT,ST_LEVELS,PP_POS(POS), INMOSES1.91
& LOOKUP,LEN1_LOOKUP, INMOSES1.92
& D1_TDEEP,P_FIELD,FIXHD, INMOSES1.93
*CALL ARGPPX INMOSES1.94
& ICODE,CMESSAGE) INMOSES1.95
IF (ICODE.GT.0) THEN INMOSES1.96
WRITE (6,*) ' Problem with reading TDEEP field' INMOSES1.97
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.98
END IF INMOSES1.99
END IF INMOSES1.100
CALL LOCATE (43,PP_ITEMC,N_TYPES,POS) INMOSES1.101
IF (POS.EQ.0) THEN INMOSES1.102
CMESSAGE = INMOSES1.103
& 'INIT_MOSES: Problem with initialising STHU' INMOSES1.104
WRITE (6,*) 'V_SAT not found in output dump' INMOSES1.105
CALL ABORT INMOSES1.106
ELSE INMOSES1.107
CALL READFLDS (NFTOUT,1,PP_POS(POS), INMOSES1.108
& LOOKUP,LEN1_LOOKUP, INMOSES1.109
& D1_VSAT,P_FIELD,FIXHD, INMOSES1.110
*CALL ARGPPX INMOSES1.111
& ICODE,CMESSAGE) INMOSES1.112
IF (ICODE.GT.0) THEN INMOSES1.113
WRITE (6,*) ' Problem with reading V_SAT field' INMOSES1.114
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.115
END IF INMOSES1.116
END IF INMOSES1.117
CALL LOCATE (207,PP_ITEMC,N_TYPES,POS) INMOSES1.118
IF (POS.EQ.0) THEN INMOSES1.119
CMESSAGE = INMOSES1.120
& 'INIT_MOSES: Problem with initialising STHU' INMOSES1.121
WRITE (6,*) 'Clapp-H B Coeff not found in output dump' INMOSES1.122
CALL ABORT INMOSES1.123
ELSE INMOSES1.124
CALL READFLDS (NFTOUT,1,PP_POS(POS), INMOSES1.125
& LOOKUP,LEN1_LOOKUP, INMOSES1.126
& D1_BEXP,P_FIELD,FIXHD, INMOSES1.127
*CALL ARGPPX INMOSES1.128
& ICODE,CMESSAGE) INMOSES1.129
IF (ICODE.GT.0) THEN INMOSES1.130
WRITE (6,*) ' Problem with reading B exponent field.' INMOSES1.131
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.132
END IF INMOSES1.133
END IF INMOSES1.134
CALL LOCATE (48,PP_ITEMC,N_TYPES,POS) INMOSES1.135
IF (POS.EQ.0) THEN INMOSES1.136
CMESSAGE = INMOSES1.137
& 'INIT_MOSES: Problem with initialising STHU' INMOSES1.138
WRITE (6,*) 'SATHH not found in output dump' INMOSES1.139
CALL ABORT INMOSES1.140
ELSE INMOSES1.141
CALL READFLDS (NFTOUT,1,PP_POS(POS), INMOSES1.142
& LOOKUP,LEN1_LOOKUP, INMOSES1.143
& D1_SATHH,P_FIELD,FIXHD, INMOSES1.144
*CALL ARGPPX INMOSES1.145
& ICODE,CMESSAGE) INMOSES1.146
IF (ICODE.GT.0) THEN INMOSES1.147
WRITE (6,*) ' Problem with reading SATHH field' INMOSES1.148
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.149
END IF INMOSES1.150
END IF INMOSES1.151
INMOSES1.152
! Initialise unfrozen and frozen soil moisture fractions INMOSES1.153
! using subroutine FREEZE_SOIL INMOSES1.154
CALL FREEZE_SOIL(LAND_POINTS,SM_LEVELS,D1_BEXP,DZSOIL, INMOSES1.155
& D1_SATHH,D1_SMCL,D1_TDEEP,D1_VSAT, INMOSES1.156
& D1_STHU,D1_STHF) INMOSES1.157
CALL LOCATE (214,PP_ITEMC,N_TYPES,POS) INMOSES1.158
CALL WRITFLDS (NFTOUT,SM_LEVELS,PP_POS(POS), INMOSES1.159
& LOOKUP,LEN1_LOOKUP, INMOSES1.160
& D1_STHU,LAND_POINTS,FIXHD, INMOSES1.161
*CALL ARGPPX INMOSES1.162
& ICODE,CMESSAGE) INMOSES1.163
IF (ICODE.GT.0) THEN INMOSES1.164
WRITE (6,*) ' Problem with writing STHU' INMOSES1.165
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.166
END IF INMOSES1.167
WRITE (6,*) ' STHU (Stash Code 214) has ', INMOSES1.168
& 'been initialised using subroutine FREEZE_SOIL' INMOSES1.169
CALL LOCATE (215,PP_ITEMC,N_TYPES,POS) INMOSES1.170
CALL WRITFLDS (NFTOUT,SM_LEVELS,PP_POS(POS), INMOSES1.171
& LOOKUP,LEN1_LOOKUP, INMOSES1.172
& D1_STHF,LAND_POINTS,FIXHD, INMOSES1.173
*CALL ARGPPX INMOSES1.174
& ICODE,CMESSAGE) INMOSES1.175
IF (ICODE.GT.0) THEN INMOSES1.176
WRITE (6,*) ' Problem with writing STHF' INMOSES1.177
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) INMOSES1.178
END IF INMOSES1.179
WRITE (6,*) ' STHF (Stash Code 215) has ', INMOSES1.180
& 'been initialised using subroutine FREEZE_SOIL' INMOSES1.181
INMOSES1.182
RETURN INMOSES1.183
END INMOSES1.184
*ENDIF INMOSES1.185