| 1 | SUBROUTINE SUPHEC(KULOUT) |
|---|
| 2 | |
|---|
| 3 | !**** *SUPHEC - INITIALISES PHYSICAL CONSTANTS OF UNCERTAIN VALUE. |
|---|
| 4 | ! WITHIN THE E.C.M.W.F. PHYSICS PACKAGE |
|---|
| 5 | |
|---|
| 6 | ! PURPOSE. |
|---|
| 7 | ! -------- |
|---|
| 8 | |
|---|
| 9 | ! THIS ROUTINE SETS THE VALUES FOR THE PHYSICAL CONSTANTS USED |
|---|
| 10 | ! IN THE PARAMETERIZATION ROUTINES WHENEVER THESE VALUES ARE NOT |
|---|
| 11 | ! KNOWN WELL ENOUGH TO FORBID ANY TUNING OR WHENEVER THEY ARE |
|---|
| 12 | ! SUBJECT TO AN ARBITRARY CHOICE OF THE MODELLER. THESE CONSTANTS |
|---|
| 13 | ! ARE DISTRIBUTED IN COMMON DECKS *YOEXXXX* WHERE XXXX CORRESPONDS |
|---|
| 14 | ! TO THE INDIVIDUAL PHYSICAL PARAMETRIZATION |
|---|
| 15 | |
|---|
| 16 | !** INTERFACE. |
|---|
| 17 | ! ---------- |
|---|
| 18 | |
|---|
| 19 | ! *SUPHEC* IS CALLED FROM *SUPHY* |
|---|
| 20 | |
|---|
| 21 | ! METHOD. |
|---|
| 22 | ! ------- |
|---|
| 23 | |
|---|
| 24 | ! NONE. |
|---|
| 25 | |
|---|
| 26 | ! EXTERNALS. |
|---|
| 27 | ! ---------- |
|---|
| 28 | |
|---|
| 29 | ! *SUECRAD*, *SUCUMF*, *SUCUMF2*,*SUVDFS*, *SUSURF* |
|---|
| 30 | ! *SUECRAD15*, *SUCLOP15* |
|---|
| 31 | ! *SUGWD*, *SUCLD*, *SUCOND*, *SUPHLI*, *SUMETHOX* |
|---|
| 32 | |
|---|
| 33 | ! REFERENCE. |
|---|
| 34 | ! ---------- |
|---|
| 35 | |
|---|
| 36 | ! SEE PHYSICAL ROUTINES FOR AN EXACT DEFINITION OF THE |
|---|
| 37 | ! CONSTANTS. |
|---|
| 38 | |
|---|
| 39 | ! AUTHOR. |
|---|
| 40 | ! ------- |
|---|
| 41 | ! J.-J. MORCRETTE E.C.M.W.F. 91/06/15 ADAPTATION TO I.F.S. |
|---|
| 42 | |
|---|
| 43 | ! MODIFICATIONS |
|---|
| 44 | ! ------------- |
|---|
| 45 | ! MAY 1997 : M. Deque - Frozen FMR |
|---|
| 46 | ! APRIL 1998: C. JAKOB - ADD METHANE OXIDATION |
|---|
| 47 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning |
|---|
| 48 | ! P.Viterbo 24-May-2004 surf library |
|---|
| 49 | ! P.Viterbo 03-Dec-2004 Include user-defined RTHRFRTI |
|---|
| 50 | ! M.Ko"hler 03-Dec-2004 cp,moist=cp,dry |
|---|
| 51 | ! P.Viterbo 10-Jun-2005 Externalise surf |
|---|
| 52 | ! R. El Khatib & J-F Estrade 20-Jan-2005 Default PRSUN for FMR15 |
|---|
| 53 | ! D.Salmond 22-Nov-2005 Mods for coarser/finer physics |
|---|
| 54 | ! P. Lopez 21-Aug-2006 Added call to SUCUMF2 |
|---|
| 55 | ! (new linearized convec) |
|---|
| 56 | ! JJMorcrette 20060525 MODIS albedo |
|---|
| 57 | ! ------------------------------------------------------------------ |
|---|
| 58 | |
|---|
| 59 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
|---|
| 60 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK |
|---|
| 61 | |
|---|
| 62 | USE YOMDPHY , ONLY : NTILES |
|---|
| 63 | USE SURFACE_FIELDS, ONLY : YSP_SBD |
|---|
| 64 | USE YOELW , ONLY : NSIL ,TSTAND ,XP |
|---|
| 65 | USE YOESW , ONLY : RSUN |
|---|
| 66 | USE YOMSW15 , ONLY : RSUN15 |
|---|
| 67 | USE YOMDIM , ONLY : NFLEVG ,NSMAX, NGPBLKS, NPROMA |
|---|
| 68 | USE YOMGEM , ONLY : VBH ,VAH ,VP00, VAF , VBF |
|---|
| 69 | USE YOMCST , ONLY : RD ,RV ,RCPD ,& |
|---|
| 70 | & RLVTT ,RLSTT ,RLMLT ,RTT ,RATM |
|---|
| 71 | !USE YOETHF , ONLY : R2ES ,R3LES ,R3IES ,R4LES ,& |
|---|
| 72 | ! & R4IES ,R5LES ,R5IES ,RVTMP2 ,RHOH2O ,& |
|---|
| 73 | ! & R5ALVCP ,R5ALSCP ,RALVDCP ,RALSDCP ,RALFDCP ,& |
|---|
| 74 | ! & RTWAT ,RTBER ,RTBERCU ,RTICE ,RTICECU ,& |
|---|
| 75 | ! & RTWAT_RTICE_R ,RTWAT_RTICECU_R ,& |
|---|
| 76 | ! & RKOOP1 ,RKOOP2 |
|---|
| 77 | USE YOMPHY , ONLY : LRAYFM15 |
|---|
| 78 | !USE YOERAD , ONLY : NSW ,NTSW ,& |
|---|
| 79 | ! NSW mis dans .def MPL 20140211 |
|---|
| 80 | USE YOERAD , ONLY : NTSW ,& |
|---|
| 81 | & LCCNL ,LCCNO ,& |
|---|
| 82 | & RCCNSEA ,RCCNLND |
|---|
| 83 | USE YOE_TILE_PROP, ONLY : RUSTRTI, RVSTRTI, RAHFSTI, REVAPTI, RTSKTI |
|---|
| 84 | USE YOEPHY , ONLY : RTHRFRTI ,LEOCWA ,LEOCCO ,LEOCSA, LE4ALB |
|---|
| 85 | USE YOEVDF , ONLY : NVTYPES |
|---|
| 86 | USE YOMCOAPHY , ONLY : NPHYINT |
|---|
| 87 | USE YOM_PHYS_GRID ,ONLY : PHYS_GRID |
|---|
| 88 | USE YOMCT0 , ONLY : LSCMEC ,LROUGH ,REXTZ0M ,REXTZ0H |
|---|
| 89 | USE lmdz_vertical_layers, ONLY: ap,bp |
|---|
| 90 | |
|---|
| 91 | IMPLICIT NONE |
|---|
| 92 | include "YOETHF.h" |
|---|
| 93 | include "clesphys.h" |
|---|
| 94 | |
|---|
| 95 | INTEGER(KIND=JPIM),INTENT(IN) :: KULOUT |
|---|
| 96 | INTERFACE |
|---|
| 97 | #include "susurf.h" |
|---|
| 98 | #include "surf_inq.h" |
|---|
| 99 | END INTERFACE |
|---|
| 100 | |
|---|
| 101 | #include "gppre.intfb.h" |
|---|
| 102 | #include "sucld.intfb.h" |
|---|
| 103 | #include "sucldp.intfb.h" |
|---|
| 104 | #include "suclop.intfb.h" |
|---|
| 105 | #include "suclop15.intfb.h" |
|---|
| 106 | #include "sucond.intfb.h" |
|---|
| 107 | #include "sucumf.intfb.h" |
|---|
| 108 | #include "sucumf2.intfb.h" |
|---|
| 109 | #include "suecrad.intfb.h" |
|---|
| 110 | #include "suecrad15.intfb.h" |
|---|
| 111 | #include "sugwd.intfb.h" |
|---|
| 112 | #include "sumethox.intfb.h" |
|---|
| 113 | #include "suphli.intfb.h" |
|---|
| 114 | #include "suvdf.intfb.h" |
|---|
| 115 | #include "suvdfs.intfb.h" |
|---|
| 116 | #include "suwcou.intfb.h" |
|---|
| 117 | |
|---|
| 118 | ! ------------------------------------------------------------------ |
|---|
| 119 | |
|---|
| 120 | REAL(KIND=JPRB) :: ZPRES(0:NFLEVG),ZPRESF(NFLEVG), ZETA(NFLEVG),ZETAH(0:NFLEVG) |
|---|
| 121 | |
|---|
| 122 | INTEGER(KIND=JPIM) :: JK,ISMAX,JLEV |
|---|
| 123 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
|---|
| 124 | |
|---|
| 125 | ! ------------------------------------------------------------------ |
|---|
| 126 | |
|---|
| 127 | !* 0.2 DEFINING DERIVED CONSTANTS FROM UNIVERSAL CONSTANTS |
|---|
| 128 | ! --------------------------------------------------- |
|---|
| 129 | |
|---|
| 130 | IF (LHOOK) CALL DR_HOOK('SUPHEC',0,ZHOOK_HANDLE) |
|---|
| 131 | ! |
|---|
| 132 | IF (OK_BAD_ECMWF_THERMO) THEN |
|---|
| 133 | ! |
|---|
| 134 | ! Modify constants defined in suphel.F90 and set RVTMP2 to 0. |
|---|
| 135 | ! CALL GSTATS(1811,0) ! MPL 28.11.08 |
|---|
| 136 | ! RVTMP2=RCPV/RCPD-1.0_JPRB !use cp,moist |
|---|
| 137 | RVTMP2=0.0_JPRB !neglect cp,moist |
|---|
| 138 | RHOH2O=RATM/100._JPRB |
|---|
| 139 | R2ES=611.21_JPRB*RD/RV |
|---|
| 140 | R3LES=17.502_JPRB |
|---|
| 141 | R3IES=22.587_JPRB |
|---|
| 142 | R4LES=32.19_JPRB |
|---|
| 143 | R4IES=-0.7_JPRB |
|---|
| 144 | R5LES=R3LES*(RTT-R4LES) |
|---|
| 145 | R5IES=R3IES*(RTT-R4IES) |
|---|
| 146 | R5ALVCP=R5LES*RLVTT/RCPD |
|---|
| 147 | R5ALSCP=R5IES*RLSTT/RCPD |
|---|
| 148 | RALVDCP=RLVTT/RCPD |
|---|
| 149 | RALSDCP=RLSTT/RCPD |
|---|
| 150 | RALFDCP=RLMLT/RCPD |
|---|
| 151 | RTWAT=RTT |
|---|
| 152 | RTBER=RTT-5._JPRB |
|---|
| 153 | RTBERCU=RTT-5.0_JPRB |
|---|
| 154 | RTICE=RTT-23._JPRB |
|---|
| 155 | RTICECU=RTT-23._JPRB |
|---|
| 156 | |
|---|
| 157 | RTWAT_RTICE_R=1.0_JPRB/(RTWAT-RTICE) |
|---|
| 158 | RTWAT_RTICECU_R=1.0_JPRB/(RTWAT-RTICECU) |
|---|
| 159 | IF(NPHYINT == 0) THEN |
|---|
| 160 | ISMAX=NSMAX |
|---|
| 161 | ELSE |
|---|
| 162 | ISMAX=PHYS_GRID%NSMAX |
|---|
| 163 | ENDIF |
|---|
| 164 | |
|---|
| 165 | RKOOP1=2.583_JPRB |
|---|
| 166 | RKOOP2=0.48116E-2_JPRB |
|---|
| 167 | |
|---|
| 168 | ELSE |
|---|
| 169 | ! Keep constants defined in suphel.F90 |
|---|
| 170 | RTICE=RTT-23._JPRB |
|---|
| 171 | ! |
|---|
| 172 | ENDIF ! (OK_BAD_ECMWF_THERMO) |
|---|
| 173 | |
|---|
| 174 | ! ------------------------------------------------------------------ |
|---|
| 175 | !* 0.5 DEFINE STANDARD ATMOSPHERE VERTICAL CONFIGURATION |
|---|
| 176 | ! ------------------------------------------------- |
|---|
| 177 | !ALLOCATE(VBH (0:MAX(JPMXLE,NFLEVG))) from suallo.F90 |
|---|
| 178 | !! |
|---|
| 179 | ALLOCATE(VAH (0:NFLEVG)) ! Ajout ALLOCATE MPL 200509 |
|---|
| 180 | ALLOCATE(VBH (0:NFLEVG)) |
|---|
| 181 | ALLOCATE(VAF (NFLEVG)) |
|---|
| 182 | ALLOCATE(VBF (NFLEVG)) |
|---|
| 183 | ! Commente par MPL 28.11.08, puis decommente le 19.05.09 |
|---|
| 184 | VP00=101325. !!!!! A REVOIR (MPL) |
|---|
| 185 | ZPRES(NFLEVG)=VP00 |
|---|
| 186 | ! on recupere ap et bp de dyn3d (lmdz_vertical_layers) MPL 19.05.09 |
|---|
| 187 | ! Attention, VAH et VBH sont inverses, comme les niveaux |
|---|
| 188 | ! plev(l)=PAPRS(klon,nlayer+1-l) de 1 a nlayer (apllmd.F) |
|---|
| 189 | DO JLEV = 0, NFLEVG |
|---|
| 190 | ! VAH(JLEV)=ap(JLEV+1)ap(JLEV+1) |
|---|
| 191 | ! VBH(JLEV)=bp(JLEV+1) |
|---|
| 192 | ! print *,'SUPHEC: jlev ap bp',JLEV,ap(JLEV+1),bp(JLEV+1) |
|---|
| 193 | VAH(JLEV)=ap(NFLEVG+1-JLEV) |
|---|
| 194 | VBH(JLEV)=bp(NFLEVG+1-JLEV) |
|---|
| 195 | ENDDO |
|---|
| 196 | ! Calcul de VAF et VBF, analogues de VAH et VBH mais aux niveaux pleins |
|---|
| 197 | DO JLEV = 1, NFLEVG |
|---|
| 198 | VAF(JLEV)=(VAH(JLEV)+VAH(JLEV-1))/2. |
|---|
| 199 | VBF(JLEV)=(VBH(JLEV)+VBH(JLEV-1))/2. |
|---|
| 200 | ENDDO |
|---|
| 201 | |
|---|
| 202 | ! Appel a GPPRE commente par MPL 28.11.08, puis decommente le 19.05.09 |
|---|
| 203 | CALL GPPRE ( 1 ,1, 1, NFLEVG, VAH, VBH, ZPRES, ZPRESF ) |
|---|
| 204 | |
|---|
| 205 | DO JK=0,NFLEVG |
|---|
| 206 | ZETAH(JK)= ZPRES(JK)/ZPRES(NFLEVG) |
|---|
| 207 | ENDDO |
|---|
| 208 | DO JK=1,NFLEVG |
|---|
| 209 | ZETA(JK)= ZPRESF(JK)/ZPRES(NFLEVG) |
|---|
| 210 | ENDDO |
|---|
| 211 | |
|---|
| 212 | ! ------------------------------------------------------------------ |
|---|
| 213 | !* 1. SETTING CONSTANTS FOR DIAGNOSTIC CLOUD SCHEME |
|---|
| 214 | ! --------------------------------------------- |
|---|
| 215 | |
|---|
| 216 | !CALL SUCLD ( NFLEVG , ZETA ) ! MPL 28.11.08 |
|---|
| 217 | |
|---|
| 218 | ! ------------------------------------------------------------------ |
|---|
| 219 | |
|---|
| 220 | !* 2. SETTING CONSTANTS FOR LARGE-SCALE CONDENSATION SCHEME |
|---|
| 221 | ! ----------------------------------------------------- |
|---|
| 222 | |
|---|
| 223 | !CALL SUCOND ( KULOUT , NFLEVG , ZETA ) ! MPL 28.11.08 |
|---|
| 224 | |
|---|
| 225 | ! ------------------------------------------------------------------ |
|---|
| 226 | |
|---|
| 227 | !* 3. SETTING CONSTANTS FOR CONVECTION SCHEME |
|---|
| 228 | ! --------------------------------------- |
|---|
| 229 | |
|---|
| 230 | !CALL SUCUMF(ISMAX) ! MPL 28.11.08 |
|---|
| 231 | |
|---|
| 232 | ! ------------------------------------------------------------------ |
|---|
| 233 | |
|---|
| 234 | !* 3. SETTING CONSTANTS FOR NEW LINEARIZED CONVECTION SCHEME |
|---|
| 235 | ! ------------------------------------------------------ |
|---|
| 236 | |
|---|
| 237 | !CALL SUCUMF2(ISMAX) ! MPL 28.11.08 |
|---|
| 238 | |
|---|
| 239 | ! ------------------------------------------------------------------ |
|---|
| 240 | !* 4. SETTING CONSTANTS FOR GRAVITY WAVE DRAG SCHEME |
|---|
| 241 | ! ---------------------------------------------- |
|---|
| 242 | |
|---|
| 243 | !CALL SUGWD (KULOUT, NFLEVG, VAH, VBH ) ! MPL 28.11.08 |
|---|
| 244 | |
|---|
| 245 | ! ------------------------------------------------------------------ |
|---|
| 246 | |
|---|
| 247 | !* 5. SETTING CONSTANTS FOR VERTICAL DIFFUSION |
|---|
| 248 | ! ---------------------------------------- |
|---|
| 249 | |
|---|
| 250 | !CALL SUVDFS ! MPL 28.11.08 |
|---|
| 251 | |
|---|
| 252 | !CALL SUVDF ! MPL 28.11.08 |
|---|
| 253 | |
|---|
| 254 | !cccc CALL SUVDFD ( NABLPFR, ABLPLL ) cccccccccccccccccccccccccccccccccc |
|---|
| 255 | |
|---|
| 256 | ! ------------------------------------------------------------------ |
|---|
| 257 | |
|---|
| 258 | !* 6. SETTING CONSTANTS FOR RADIATION SCHEME |
|---|
| 259 | ! -------------------------------------- |
|---|
| 260 | |
|---|
| 261 | IF (LRAYFM15) THEN |
|---|
| 262 | CALL SUECRAD15 (KULOUT, NFLEVG, ZETAH ) |
|---|
| 263 | ELSE |
|---|
| 264 | CALL SUECRAD (KULOUT, NFLEVG, ZETAH ) |
|---|
| 265 | ENDIF |
|---|
| 266 | |
|---|
| 267 | ! ------------------------------------------------------------------ |
|---|
| 268 | !* 7. SETTING CONSTANTS FOR SURFACE SCHEME |
|---|
| 269 | ! ------------------------------------ |
|---|
| 270 | |
|---|
| 271 | !IF (LRAYFM15) THEN |
|---|
| 272 | ! CALL SUSURF(KSW=NSW,KCSS=YSP_SBD%NLEVS,KSIL=NSIL,KTILES=NTILES,KTSW=NTSW,& |
|---|
| 273 | ! & LD_LLCCNL=LCCNL,LD_LLCCNO=LCCNO,& |
|---|
| 274 | ! & LD_LEOCWA=LEOCWA,LD_LEOCCO=LEOCCO,LD_LEOCSA=LEOCSA,LD_LLE4ALB=LE4ALB,& |
|---|
| 275 | ! & LD_LSCMEC=LSCMEC,LD_LROUGH=LROUGH,PEXTZ0M=REXTZ0M,PEXTZ0H=REXTZ0H,& |
|---|
| 276 | ! & PTHRFRTI=RTHRFRTI,PTSTAND=TSTAND,PXP=XP,PRCCNSEA=RCCNSEA,PRCCNLND=RCCNLND,& |
|---|
| 277 | ! & PRSUN=RSUN15) |
|---|
| 278 | !ELSE |
|---|
| 279 | ! CALL SUSURF(KSW=NSW,KCSS=YSP_SBD%NLEVS,KSIL=NSIL,KTILES=NTILES,KTSW=NTSW,& |
|---|
| 280 | ! & LD_LLCCNL=LCCNL,LD_LLCCNO=LCCNO,& |
|---|
| 281 | ! & LD_LEOCWA=LEOCWA,LD_LEOCCO=LEOCCO,LD_LEOCSA=LEOCSA,LD_LLE4ALB=LE4ALB,& |
|---|
| 282 | ! & LD_LSCMEC=LSCMEC,LD_LROUGH=LROUGH,PEXTZ0M=REXTZ0M,PEXTZ0H=REXTZ0H,& |
|---|
| 283 | ! & PTHRFRTI=RTHRFRTI,PTSTAND=TSTAND,PXP=XP,PRCCNSEA=RCCNSEA,PRCCNLND=RCCNLND,& |
|---|
| 284 | ! & PRSUN=RSUN) |
|---|
| 285 | !ENDIF |
|---|
| 286 | |
|---|
| 287 | |
|---|
| 288 | !CALL SURF_INQ(KNVTYPES=NVTYPES) |
|---|
| 289 | |
|---|
| 290 | |
|---|
| 291 | ! 7.1 Allocate working arrays |
|---|
| 292 | !ALLOCATE(RUSTRTI(NPROMA,NTILES,NGPBLKS)) |
|---|
| 293 | !ALLOCATE(RVSTRTI(NPROMA,NTILES,NGPBLKS)) |
|---|
| 294 | !ALLOCATE(RAHFSTI(NPROMA,NTILES,NGPBLKS)) |
|---|
| 295 | !ALLOCATE(REVAPTI(NPROMA,NTILES,NGPBLKS)) |
|---|
| 296 | !ALLOCATE(RTSKTI (NPROMA,NTILES,NGPBLKS)) |
|---|
| 297 | !RUSTRTI(:,:,:) = 0.0_JPRB |
|---|
| 298 | !RVSTRTI(:,:,:) = 0.0_JPRB |
|---|
| 299 | !RAHFSTI(:,:,:) = 0.0_JPRB |
|---|
| 300 | !REVAPTI(:,:,:) = 0.0_JPRB |
|---|
| 301 | !RTSKTI (:,:,:) = 0.0_JPRB |
|---|
| 302 | !CALL GSTATS(1811,1) |
|---|
| 303 | |
|---|
| 304 | ! ------------------------------------------------------------------ |
|---|
| 305 | |
|---|
| 306 | !* 8. SETTING CONSTANTS FOR CLOUD OPTICAL PROPERTIES |
|---|
| 307 | ! ---------------------------------------------- |
|---|
| 308 | |
|---|
| 309 | IF (LRAYFM15) THEN |
|---|
| 310 | CALL SUCLOP15 |
|---|
| 311 | ELSE |
|---|
| 312 | CALL SUCLOP |
|---|
| 313 | ENDIF |
|---|
| 314 | |
|---|
| 315 | ! ------------------------------------------------------------------ |
|---|
| 316 | |
|---|
| 317 | !* 9. SETTING CONSTANTS FOR PROGNOSTIC CLOUD SCHEME |
|---|
| 318 | ! ---------------------------------------------- |
|---|
| 319 | |
|---|
| 320 | !CALL SUCLDP |
|---|
| 321 | |
|---|
| 322 | ! ------------------------------------------------------------------ |
|---|
| 323 | |
|---|
| 324 | !* 10. SETTING CONSTANTS FOR WAVE COUPLING |
|---|
| 325 | ! ----------------------------------- |
|---|
| 326 | |
|---|
| 327 | !CALL SUWCOU |
|---|
| 328 | |
|---|
| 329 | ! ------------------------------------------------------------------ |
|---|
| 330 | !* 11. SETTING CONSTANTS FOR LINEARIZED PHYSICS |
|---|
| 331 | ! ---------------------------------------- |
|---|
| 332 | |
|---|
| 333 | !CALL SUPHLI |
|---|
| 334 | |
|---|
| 335 | ! ------------------------------------------------------------------ |
|---|
| 336 | !* 12. SETTING CONSTANTS FOR METHANE OXIDATION |
|---|
| 337 | ! --------------------------------------- |
|---|
| 338 | |
|---|
| 339 | !CALL SUMETHOX |
|---|
| 340 | |
|---|
| 341 | ! ------------------------------------------------------------------ |
|---|
| 342 | |
|---|
| 343 | WRITE(UNIT=KULOUT,FMT='('' SUPHEC IS OVER '')') |
|---|
| 344 | |
|---|
| 345 | ! ------------------------------------------------------------------ |
|---|
| 346 | |
|---|
| 347 | IF (LHOOK) CALL DR_HOOK('SUPHEC',1,ZHOOK_HANDLE) |
|---|
| 348 | END SUBROUTINE SUPHEC |
|---|
